home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Anwendungen / Kurztests / PostScript / PsIntrp / ps.a < prev    next >
Text File  |  1987-09-06  |  20KB  |  1,378 lines
  1. *
  2. *    This program is in the public domain.    PostScript is a trademark
  3. *    of Adobe Systems.
  4. *        Greg Lee, July, 1987.
  5. *    U.S. mail: 562 Moore Hall, Dept. of Linguistics
  6. * INTERNET: lee@uhccux.uhcc.hawaii.edu
  7. * UUCP:    {ihnp4,dcdwest,ucbvax}!sdcsvax!nosc!uhccux!lee
  8. * BITNET:    lee%uhccux.uhcc.hawaii.edu@rutgers.edu
  9. *
  10.  
  11.  
  12. * link with ffpa.o
  13.     xref    FFPAFP
  14. * link with lmath.o
  15.     xref    lmulu
  16.     xref    ldivu
  17.     xref    ldivs
  18. * link with files.o
  19.     xref    readln
  20.     xref    runclose
  21.     xref    showreal
  22.     xref    show8x
  23.     xref    showdec
  24.     xref    newline
  25.     xref    getstr
  26.     xref    msg,longmsg
  27.     xref    ioinit
  28.     xref    endio
  29. * in control.o
  30.     xref    initloops
  31.     xref    _exec
  32. * in graphics.o
  33.     xref    initgr,endgr
  34. * in rmath.o
  35.     xref    _gsave,_grestore
  36. * in dict.o
  37.     xref    systemdict
  38.     xref    fdict,enddict
  39.     xref    .true,.false
  40.  
  41.  
  42.  
  43.     xdef    reinterp
  44.  
  45.     xdef    ihandle,ohandle
  46.     xdef    rastport,wbscreen
  47.     xdef    intuitionbase
  48.     xdef    graphicsbase
  49.     xdef    mathffpbase
  50.     xdef    mathtransbase
  51.  
  52.  
  53.  
  54.  
  55.     idnt    PS
  56.  
  57.     section    one
  58.  
  59.     include    "ps.h"
  60.  
  61.  
  62. math    macro
  63.     move.l    A6,-(SP)
  64.     move.l    mathffpbase,A6
  65.     jsr    _LVO\1(A6)
  66.     move.l    (SP)+,A6
  67.     endm
  68.  
  69.  
  70.     lref    Open,1
  71.     lref    Close,2
  72.     lref    Read,3
  73.     lref    Write,4
  74.     lref    Input,5
  75.     lref    Output,6
  76.     lref    DeleteFile,8
  77.     lref    IoErr,18
  78.     lref    LoadSeg,21
  79.     lref    UnLoadSeg,22
  80.     lref    IsInteractive,32
  81.  
  82.     lref    SPFix,1
  83.     lref    SPFlt,2
  84.     lref    SPCmp,3
  85.     lref    SPTst,4
  86.     lref    SPAbs,5
  87.     lref    SPNeg,6
  88.     lref    SPAdd,7
  89.     lref    SPSub,8
  90.     lref    SPMul,9
  91.     lref    SPDiv,10
  92.  
  93.  
  94.  
  95. _RTS        equ    %0100111001110101
  96. _JSR        equ    %0100111010111001    destination abs. long
  97. _JMP        equ    %0100111011111001    destination abs. long
  98. _MOVELD0    equ    %0010000000111100    source immediate long
  99. _MOVEVD0    equ    %0010000000111001    source abs. long
  100. _MOVEWD2    equ    %0011010000111100    source immediate word
  101. _MOVEVD2    equ    %0011010000111001    source abs. long
  102.  
  103.  
  104.  
  105. main
  106.     move.l    SP,stacksave
  107.     bsr    ioinit
  108.     bsr    initgr
  109.  
  110.  
  111. * here on error to redo stack
  112. main1
  113.     bsr    _clear
  114.     bsr    dsclear
  115.  
  116. * get more stuff to interpret
  117. main.in
  118.     bsr    getstr
  119. * (from here, A1 -> next stuff to interpret)
  120.  
  121.  
  122. * interpret next symbol
  123. main.next
  124.     bsr    skipsp
  125.     beq    main.in
  126.  
  127.     pea    main.next
  128.     move.b    compilelevel,D3
  129.  
  130. * if it's a number, push it
  131.     bsr    testnumber
  132.     beq    pushnum
  133.  
  134. * name literal?
  135.     cmp.b    #'/',D0
  136.     beq    pushlit
  137.  
  138.     cmp.b    #'(',D0
  139.     beq    pushstr
  140.  
  141.     cmp.b    #'{',D0
  142.     beq    start_compile
  143.  
  144.     cmp.b    #'}',D0
  145.     beq    end_compile
  146.  
  147.     cmp.b    #'%',D0
  148.     beq    getstr
  149.  
  150. * interpret a name
  151.     bsr    findsym
  152.     tst.l    D2
  153.     bpl    name.ok
  154. say_undefined
  155.     print    unknown
  156.     bra    reinterp
  157.  
  158. name.ok
  159.     move.b    compilelevel,D3
  160.     beq    no.dummies
  161.     cmp.w    #Dummy,D2
  162.     bne    no.dummies
  163.     bsr    vpush
  164.     lea    _exec,A0
  165.     move.l    A0,D0
  166.     bra    stowcall
  167.  
  168. no.dummies
  169.     cmp.w    #ICode,D2
  170.     bne    vpush
  171.  
  172.     tst.b    D3
  173.     bne    stowcall
  174.  
  175.     move.l    A1,-(SP)
  176.     move.l    D0,A0
  177.     jsr    (A0)
  178.     move.l    (SP)+,A1
  179.     rts
  180.  
  181. * exit
  182. system
  183.     bsr    endgr
  184.     bsr    endio
  185.     moveq    #0,D0
  186.     rts
  187. ***********************
  188.  
  189.     DEF    clear
  190.     lea    istacktop,A5
  191.     moveq    #Illegal,D0
  192.     move.l    D0,-(A5)
  193.     move.w    D0,-(A5)
  194.     rts
  195.  
  196. countistack
  197.     moveq    #-1,D0
  198.     moveq    #Illegal,D2
  199.     move.l    A5,A0
  200. 1$    addq.l    #1,D0
  201.     move.w    (A0),D1
  202.     addq.l    #6,A0
  203.     cmp.w    D1,D2
  204.     bne    1$
  205.     rts
  206.  
  207.     
  208.     DEF    count
  209.     bsr    countistack
  210.     RETURN    Integer
  211.  
  212. index1istack
  213.     bsr    popnum
  214.     addq.l    #1,D0
  215.     bgt    ..ndxis
  216.     bra    iuflow
  217. indexistack
  218.     bsr    popnum
  219. ..ndxis
  220.     move.l    D0,D3
  221.     bmi    iuflow
  222.     bsr    countistack
  223.     cmp.l    D0,D3
  224.     bhi    iuflow
  225.     move.l    D3,D0
  226.     subq    #1,D0
  227.     mulu    #6,D0
  228.     move.l    A5,A2
  229.     add.l    D0,A2
  230.     rts
  231.  
  232.     DEF    copy
  233.     bsr    indexistack
  234.     bra    2$
  235. 1$    move.w    (A2)+,D2
  236.     move.l    (A2),D0
  237.     bsr    r.ipush
  238.     subq.l    #8,A2
  239. 2$    dbra    D3,1$
  240.     rts
  241.  
  242.     DEF    index
  243.     bsr    index1istack
  244.     move.w    (A2)+,D2
  245.     move.l    (A2)+,D0
  246.     bra    r.ipush
  247.  
  248.     DEF    roll
  249.     bsr    popnum
  250.     move.l    D0,-(SP)
  251.     bsr    indexistack
  252.     move.l    (SP)+,D0
  253.     subq.l    #1,D3
  254.     bmi    2$
  255.     move.l    D3,D4
  256. 1$    move.l    D4,D3
  257.     bsr    roll1
  258.     bne    1$
  259. 2$    rts
  260. roll1
  261.     tst.l    D0
  262.     beq    1$
  263.     bmi    rollm
  264.     bra    rollp
  265. 1$    rts
  266.  
  267. rollp
  268.     subq.l    #1,D0
  269.     move.l    D0,-(SP)
  270.     move.l    A5,A0
  271.     move.l    A5,A1
  272.     move.w    (A0)+,-(SP)
  273.     move.l    (A0)+,-(SP)
  274.     bra    2$
  275. 1$    move.w    (A0)+,(A1)+
  276.     move.l    (A0)+,(A1)+
  277. 2$    dbra    D3,1$
  278.     move.l    (SP)+,D0
  279.     move.w    (SP)+,(A1)+
  280.     move.l    D0,(A1)
  281.     move.l    (SP)+,D0
  282.     rts
  283.  
  284. rollm
  285.     addq.l    #1,D0
  286.     move.l    D0,-(SP)
  287.     move.l    A2,A1
  288.     move.l    A2,A0
  289.     subq.l    #6,A0
  290.     move.w    (A2)+,-(SP)
  291.     move.l    (A2)+,-(SP)
  292.     bra    2$
  293. 1$    move.w    (A0)+,(A1)+
  294.     move.l    (A0),(A1)
  295.     subq.l    #8,A0
  296.     subq.l    #8,A1
  297. 2$    dbra    D3,1$
  298.     move.l    (SP)+,D0
  299.     move.w    (SP)+,(A1)+
  300.     move.l    D0,(A1)
  301.     move.l    (SP)+,D0
  302.     rts
  303.  
  304. dsclear
  305.     lea    dstacktop,A0
  306.     move.l    A0,dstack
  307.     moveq    #0,D0
  308.     move.w    D0,dstackcnt
  309.     lea    sstacktop,A0
  310.     move.l    A0,sstack
  311.     moveq    #0,D0
  312.     move.w    D0,sstackcnt
  313.     rts
  314.  
  315.  
  316. start_compile
  317.     addq.l    #1,A1
  318.     move.b    compilelevel,D0
  319.     move.w    D0,-(SP)
  320.     move.l    nextcode,A0
  321.     move.w    #ICode,D2
  322.     move.w    (SP),D0
  323.     tst.b    D0
  324.     beq    2$
  325.     add.l    #6+4+6+6,A0    allow for push & jmp if doing sub-proc
  326. 2$    move.l    A0,D0
  327. * if doing sub-proc, this generates code to do the push
  328.     bsr    ipush
  329.     move.w    (SP),D0
  330.     addq.b    #1,D0
  331.     move.b    D0,compilelevel
  332.     move.w    (SP)+,D0
  333.     tst.b    D0
  334.     bne    3$
  335.     rts
  336. 3$
  337.     move.w    #_JMP,D0
  338.     bsr    stowword
  339.     move.l    nextcode,A0
  340.     move.l    A0,-(SP)    where to put dest of jmp
  341.     moveq    #0,D0            leave room for dest of jmp
  342.     bsr    stowword
  343.     bsr    stowword
  344.  
  345.     bsr    main.next        go compile the sub-procedure
  346. * should return to here when get matching '}'
  347.     move.l    (SP)+,A0    patch in dest of jmp
  348.     move.l    nextcode,(A0)
  349.     rts
  350.  
  351.  
  352. end_compile
  353.     addq.l    #1,A1
  354.     move.b    compilelevel,D0
  355.     beq    2$                unmatched '}'
  356.     move.w    D0,-(SP)
  357.     move.w    #_RTS,D0
  358.     bsr    stowword
  359.     move.w    (SP)+,D0
  360.     subq.b    #1,D0
  361.     move.b    D0,compilelevel
  362.     beq    1$
  363.     addq.l    #4,SP    discard ret to main.next and ret to above
  364. 1$    rts
  365. 2$    print    rbrace
  366.     bra    reinterp
  367.  
  368. testnumber
  369.     cmp.b    #'-',D0
  370.     beq    ..endtestn
  371.     cmp.b    #'+',D0
  372.     beq    ..endtestn
  373.     cmp.b    #'.',D0            (only if next is digit?)
  374.     beq    ..endtestn
  375. testdig
  376.     cmp.b    #'0',D0            * is it a decimal digit?
  377.     bcs    ..endtestn
  378.     cmp.b    #'9',D0
  379.     bhi    ..endtestn
  380.     cmp.b    D0,D0
  381. ..endtestn
  382.     rts
  383.  
  384. pushstr
  385.     addq.l    #1,A1
  386.     move.w    #1,parenlevel
  387.     move.l    farea,D0
  388.     btst    #0,D0
  389.     beq    1$
  390.     bsr    stowbyte
  391.     move.l    farea,D0
  392. 1$
  393.     move.l    D0,-(SP)    place to put length
  394.     move.w    #String,D2
  395.     bsr    ipush
  396.  
  397.     moveq    #0,D0
  398.     move.w    D0,-(SP)    count length
  399.     bsr    stowbyte    room for length
  400.     bsr    stowbyte
  401.  
  402. ..nextsbyte
  403.     addq.w    #1,(SP)
  404.     pea    ..nextsbyte
  405.     move.b    (A1)+,D0
  406.     bne    2$
  407.     move.b    #10,D0
  408.     bsr    stowbyte
  409.     bra    getstr
  410.  
  411. 2$    cmp.b    #'(',D0
  412.     bne    3$
  413.     add.w    #1,parenlevel
  414.     bra    stowbyte
  415.  
  416. 3$    cmp.b    #')',D0
  417.     bne    4$
  418.     sub.w    #1,parenlevel
  419.     bne    stowbyte
  420.     addq.l    #4,SP    discard ret to ..nextsbyte
  421.  
  422.     move.w    (SP)+,D0
  423.     subq.w    #1,D0    correct for ')' not stored
  424.     move.l    (SP)+,A0
  425.     move.w    D0,(A0)
  426.     rts
  427.  
  428. 4$    cmp.b    #'\',D0
  429.     bne    stowbyte
  430.     move.b    (A1)+,D0
  431.     beq    getstr
  432.     move.b    D0,D1
  433.  
  434.     move.b    #10,D0
  435.     cmp.b    #'n',D1
  436.     beq    stowbyte
  437.  
  438.     move.b    #13,D0
  439.     cmp.b    #'r',D1
  440.     beq    stowbyte
  441.  
  442.     move.b    #9,D0
  443.     cmp.b    #'t',D1
  444.     beq    stowbyte
  445.  
  446.     move.b    #8,D0
  447.     cmp.b    #'b',D1
  448.     beq    stowbyte
  449.  
  450.     move.b    #12,D0
  451.     cmp.b    #'f',D1
  452.     beq    stowbyte
  453.  
  454.     cmp.b    #'0',D1
  455.     bcs    ..noct
  456.     cmp.b    #'7',D1
  457.     bhi    ..noct
  458.     moveq    #0,D0
  459.     bsr    ..isoct
  460.     bsr    ..isoct
  461.     sub.b    #'0',D1
  462.     asl.b    #3,D0
  463.     add.b    D1,D0
  464.     bra    stowbyte
  465.  
  466. ..isoct
  467.     sub.b    #'0',D1
  468.     asl.b    #3,D0
  469.     add.b    D1,D0
  470.     move.b    (A1),D1
  471.     cmp.b    #'0',D1
  472.     bcs    1$
  473.     cmp.b    #'7',D1
  474.     bhi    1$
  475.     addq.l    #1,A1
  476.     rts
  477. 1$    addq.l    #4,SP
  478.     bra    stowbyte
  479.  
  480. ..noct
  481.     move.b    D1,D0
  482.     cmp.b    #'\',D1
  483.     beq    stowbyte
  484.     cmp.b    #'(',D1
  485.     beq    stowbyte
  486.     cmp.b    #')',D1
  487.     beq    stowbyte
  488.     rts
  489.  
  490.  
  491. pushlit
  492.     addq.l    #1,A1    past '/'
  493.     move.l    farea,A0    save to push
  494.     moveq    #0,D3        count
  495.     bsr    stowbyte    room for length
  496. 1$    move.b    (A1)+,D0
  497.     bsr    testendchar
  498.     bne    2$
  499.     move.b    D3,(A0)
  500.     subq.l    #1,A1
  501.     move.l    A0,D0
  502.     move.w    #Name,D2
  503.     bra    ipush
  504. 2$    bsr    stowbyte
  505.     addq.l    #1,D3
  506.     bra    1$
  507.  
  508. pushnum
  509.     moveq    #0,D1
  510.     move.l    D1,D2    neg flag
  511.     move.l    D1,D3    dec point flag
  512.     move.l    A1,A0
  513.     cmp.b    #'-',(A0)
  514.     bne    1$
  515.     move.b    (A1)+,D2
  516. 1$    move.b    (A1)+,D0
  517.     bsr    testdig
  518.     bne    2$
  519.     sub.b    #'0',D0
  520.     ext.w    D0
  521.     ext.l    D0
  522.  
  523.     move.l    D0,-(SP)
  524.     add.l    D1,D1
  525.     move.l    D1,D0
  526.     lsl.l    #2,D1
  527.     add.l    D0,D1
  528.     move.l    (SP)+,D0
  529.     add.l    D0,D1
  530.     bra    1$
  531.  
  532. 2$    tst.b    D3
  533.     beq    6$
  534.     cmp.b    #'E',D0
  535.     bne    realpush
  536. 3$    move.b    (A1)+,D0
  537.     cmp.b    #'-',D0
  538.     bne    5$
  539. 4$    move.b    (A1)+,D0
  540. 5$    bsr    testdig
  541.     beq    4$
  542.     bra    realpush
  543.  
  544. 6$    cmp.b    #'E',D0
  545.     beq    3$
  546.     cmp.b    #'.',D0
  547.     bne    intpush
  548.     move.b    D0,D3
  549.     bra    1$
  550.  
  551. realpush
  552.     subq.l    #1,A1
  553.     move.l    A1,-(SP)
  554.     jsr    FFPAFP
  555.     move.l    (SP)+,A1
  556.     bvs    1$
  557.     move.w    #Real,D2
  558.     move.l    D7,D0
  559.     bra    ipush
  560. 1$    print    fperr
  561.     bra    reinterp
  562.  
  563. intpush
  564.     subq.l    #1,A1
  565.     move.b    D2,D3
  566.     move.w    #Integer,D2
  567.     move.l    D1,D0
  568.     tst.b    D3
  569.     beq    ipush
  570.     neg.l    D0
  571.  
  572. ipush
  573.     move.b    compilelevel,D3
  574.     beq    r.ipush
  575.     bsr    stowmovel
  576.     bsr    stowmovew
  577. ..iptype
  578.     lea    r.ipush,A0
  579.     move.l    A0,D0
  580.     bra    stowcall
  581.  
  582. vpush
  583.     tst.b    D3
  584.     beq    r.ipush
  585.     move.l    A2,D0    get address of value
  586.     addq.l    #2,D0
  587.     move.l    A2,-(SP)
  588.     bsr    stowmovev
  589.     move.l    (SP)+,D0    get address of type
  590.     bsr    stowmovevw
  591.     bra    ..iptype
  592.  
  593.     xdef    r.ipush
  594. r.ipush
  595. *    move.l    istack,A5
  596.     move.l    D0,-(A5)
  597.     move.w    D2,-(A5)
  598.     cmp.l    #istackbot,A5
  599.     bhi    ipush.ok
  600.     print    overflow
  601. reinterp
  602.     move.b    #0,compilelevel
  603.     bsr    initloops
  604.     bsr    runclose
  605.     move.l    stacksave,SP
  606.     bra    main1
  607.  
  608. ipush.ok
  609. *    move.l    A5,istack
  610.     rts
  611.  
  612.  
  613.     xdef    ipop
  614. ipop
  615.     DEF    pop
  616. *    move.l    istack,A5
  617.     move.w    (A5)+,D2
  618.     cmp.w    #Illegal,D2
  619.     bne    ..ippok
  620. iuflow
  621.     print    underflow
  622.     bra    reinterp
  623. ..ippok
  624.     move.l    (A5)+,D0
  625. *    move.l    A5,istack
  626.     rts
  627.  
  628.     xdef    popnum
  629. popnum
  630.     bsr    ipop
  631.     cmp.w    #Integer,D2
  632.     beq    1$
  633.     cmp.w    #Real,D2
  634.     bne    type_mismatch
  635.     move.l    D1,-(SP)
  636.     math    SPFix
  637.     move.l    (SP)+,D1
  638.     move.w    #Integer,D2
  639. 1$    rts
  640.  
  641. skipsp
  642.     move.b    (A1),D0
  643.     beq    2$
  644.     cmp.b    #10,D0
  645.     beq    1$
  646.     cmp.b    #' ',D0
  647.     bne    2$
  648. 1$    addq.l    #1,A1
  649.     bra    skipsp
  650. 2$    rts
  651.  
  652. testendchar
  653.     tst.b    D0
  654.     beq    1$
  655.     cmp.b    #' ',D0
  656.     beq    1$
  657.     cmp.b    #10,D0
  658.     beq    1$
  659.     cmp.b    #'}',D0
  660.     beq    1$
  661.     cmp.b    #'{',D0
  662.     beq    1$
  663.     cmp.b    #')',D0
  664.     beq    1$
  665.     cmp.b    #'(',D0
  666.     beq    1$
  667.     cmp.b    #'/',D0
  668.     beq    1$
  669.     cmp.b    #'%',D0
  670.     beq    1$
  671.     cmp.b    #']',D0
  672.     beq    1$
  673.     cmp.b    #'[',D0
  674.     beq    1$
  675.     cmp.b    #'>',D0
  676.     beq    1$
  677.     cmp.b    #'<',D0
  678. 1$    rts
  679.  
  680. * A1 -> name to look for
  681. * return with A1 -> past name
  682. * D2 = -1 if not found, else D2 = type
  683. * D0 = value & A2 -> type of entry
  684. findsym
  685.     move.l    A1,A0
  686.     moveq    #0,D3
  687.     move.l    D3,D2
  688.  
  689. 1$    move.b    (A0)+,D0    get length in D3
  690.     bsr    testendchar
  691.     beq    2$
  692.     addq.l    #1,D3
  693.     bra    1$
  694. 2$    tst.l    D3
  695.     bne    4$
  696.     cmp.b    #'[',D0
  697.     beq    3$
  698.     cmp.b    #']',D0
  699.     bne    .nonefound
  700. 3$    moveq    #1,D3
  701. 4$    bsr    allsym
  702.     tst.l    D2
  703.     bpl    5$
  704.     move.b    compilelevel,D1
  705.     bne    dummyentry
  706. 5$    add.l    D3,A1
  707.     rts
  708.  
  709. allsym
  710.     move.w    dstackcnt,D1
  711.     move.l    dstack,A0
  712. 1$    subq.w    #1,D1
  713.     bmi    2$
  714.     move.l    (A0)+,A2
  715.     addq.l    #2,A2
  716.     movem.l    A0/D1,-(SP)
  717.     moveq    #0,D2
  718.     bsr    nextsym
  719.     movem.l    (SP)+,A0/D1
  720.     tst.l    D2
  721.     bmi    1$
  722.     rts
  723. 2$    moveq    #0,D2
  724.     lea    systemdict,A2
  725.  
  726. * also called by dictsearch
  727. nextsym
  728.     move.l    (A2)+,D0
  729.     beq    .nonefound
  730.     move.l    D0,A3    A3 -> name in dict
  731.     move.l    A1,A0    A0 -> name
  732.     move.l    D3,D1
  733.     move.w    (A2)+,D2    D2 = type
  734.     move.l    (A2)+,D0    D0 = value
  735.  
  736.     cmp.b    (A3)+,D1    same length?
  737.     bne    nextsym
  738.  
  739.     subq.l    #1,D1
  740. 4$    cmp.b    (A3)+,(A0)+
  741.     dbne    D1,4$
  742.     bne    nextsym
  743.     subq.l    #6,A2
  744.     rts
  745.  
  746. .nonefound
  747.     moveq    #-1,D2
  748.     rts
  749.  
  750. * from above -- A1 -> name; D3 = length
  751. dummyentry
  752.     move.l    A1,A0
  753.     add.l    D3,A0
  754.     move.l    A0,-(SP)
  755.     move.l    farea,A0    save for entry name
  756.     move.l    D3,D0
  757.     bsr    stowbyte    length
  758.     bra    2$
  759. 1$    move.b    (A1)+,D0
  760.     bsr    stowbyte
  761. 2$    dbra    D3,1$
  762.  
  763.     lea    say_undefined,A1
  764.     move.l    A1,D0
  765.     move.l    #Dummy,D2
  766.     bsr    newentry
  767.     subq.l    #6,A0
  768.     move.l    A0,A2
  769.     bsr    vpush
  770.     lea    _exec,A0
  771.     move.l    #ICode,D2
  772.     move.l    A0,D0
  773.     move.l    (SP)+,A1
  774.     rts
  775.  
  776.  
  777.  
  778.     DEF    begin
  779.     ARG    Dictionary
  780.     lea    dstackcnt,A0
  781.     cmp.w    #DstackSize,(A0)
  782.     beq    1$
  783.     addq.w    #1,(A0)
  784.     move.l    dstack,A0
  785.     move.l    D0,-(A0)
  786.     move.l    A0,dstack
  787.     rts
  788. 1$    print    dstackov
  789.     bra    reinterp
  790.  
  791.     DEF    end
  792.     lea    dstackcnt,A0
  793.     tst.w    (A0)
  794.     beq    1$
  795.     subq.w    #1,(A0)
  796.     move.l    dstack,A0
  797.     move.l    (A0)+,D0
  798.     move.l    A0,dstack
  799.     rts
  800. 1$    print    dstackuv
  801.     bra    reinterp
  802.  
  803. **********
  804.  
  805.  
  806. stowbyte
  807.     move.l    farea,A2
  808.     move.b    D0,(A2)+
  809.     cmp.l    #endsarea,A2
  810.     bne    1$
  811.     print    areafull
  812.     bra    reinterp
  813. 1$    move.l    A2,farea
  814.     rts
  815.  
  816. * store instruction 'move.w <D0>,D2'
  817. stowmovevw
  818.     move.l    D0,-(SP)
  819.     move.w    #_MOVEVD2,D0
  820.     bra    ..stowi
  821. * store instruction 'move.w #<D2>,D2'
  822. stowmovew
  823.     move.w    #_MOVEWD2,D0
  824.     bsr    stowword
  825.     move.w    D2,D0
  826.     bra    stowword
  827. * store instruction 'move.l <D0>,D0'
  828. stowmovev
  829.     move.l    D0,-(SP)
  830.     move.w    #_MOVEVD0,D0
  831.     bra    ..stowi
  832. * store instruction 'move.l #<D0>,D0'
  833. stowmovel
  834.     move.l    D0,-(SP)
  835.     move.w    #_MOVELD0,D0
  836.     bra    ..stowi
  837. * store instruction 'jsr <D0>'
  838. stowcall
  839.     move.l    D0,-(SP)
  840.     move.w    #_JSR,D0    change to BSR?
  841. ..stowi
  842.     bsr    stowword
  843.     move.l    (SP),D0
  844.     swap    D0
  845.     bsr    stowword
  846.     move.l    (SP)+,D0
  847.  
  848. stowword
  849.     move.l    nextcode,A2
  850.     move.w    D0,(A2)+
  851.     cmp.l    #endcode,A2
  852.     bls    1$
  853.     print    codefull
  854.     bra    reinterp
  855. 1$    move.l    A2,nextcode
  856.     rts
  857.  
  858. stowlong
  859.     swap    D0
  860.     bsr    stowword
  861.     swap    D0
  862.     bra    stowword
  863.  
  864. ************************************
  865.  
  866.     DEF    hex
  867.     bsr    ipop
  868.     bsr    show8x
  869.     move.l    A0,D0
  870.     RETURN    Name
  871.  
  872.     DEF    quit
  873.     move.l    stacksave,SP
  874.     bsr    runclose
  875.     bra    system
  876.  
  877.     DEF    cvs
  878.     ARG    String
  879.     move.l    D0,-(SP)
  880.     moveq    #-1,D0        flag this is a string conversion
  881.     bra    ..prnt
  882. ..cvs2
  883. * it better be long enough
  884.     move.l    (SP)+,A1
  885.     move.l    A1,D0
  886. * A0 -> name; A1 -> string
  887.     moveq    #0,D1
  888.     move.b    D1,(A1)+
  889.     move.b    (A0),D1
  890. 1$    move.b    (A0)+,(A1)+
  891.     dbra    D1,1$
  892.     RETURN    String
  893.  
  894. ..pors
  895.     move.l    (SP)+,D0
  896.     bne    ..cvs2
  897.     bsr    msg
  898.     bra    newline
  899.  
  900.     DEF    print
  901.     ARG    String
  902.     move.l    D0,A0
  903.     moveq    #0,D3
  904.     move.w    (A0)+,D3
  905.     bra    longmsg
  906.  
  907.  
  908.     DEF    equalsprint
  909.     moveq    #0,D0    flag this is a print
  910. ..prnt
  911.     move.l    D0,-(SP)
  912.     bsr    ipop
  913.     cmp.w    #Integer,D2
  914.     bne    2$
  915.     bsr    showdec
  916.     bra    ..pors
  917.  
  918. 2$    cmp.w    #Name,D2
  919.     bne    3$
  920.     move.l    D0,A0
  921.     bra    ..pors
  922.  
  923. 3$    cmp.w    #String,D2
  924.     bne    4$
  925.     move.l    D0,A0
  926.     move.l    (SP)+,D1
  927.     beq    30$
  928.     move.l    (SP)+,D1
  929.     bra    r.ipush    it's already a string -- should copy it?
  930. 30$
  931.     moveq    #0,D3
  932.     move.w    (A0)+,D3
  933.     bsr    longmsg
  934.     bra    newline
  935.  
  936. 4$    cmp.w    #Boolean,D2
  937.     bne    6$
  938.     lea    .true,A0
  939.     tst.l    D0
  940.     bne    5$
  941.     lea    .false,A0
  942. 5$    bra    ..pors
  943.  
  944. 6$    cmp.w    #Real,D2
  945.     bne    7$
  946.     bsr    showreal
  947.     bra    ..pors
  948.  
  949. 7$
  950.     lea    nsv,A0
  951.     bra    ..pors
  952.  
  953.  
  954.     DEF    string
  955.     bsr    popnum
  956.     move.l    D0,D3
  957.     swap    D0
  958.     tst.w    D0
  959.     bne    2$
  960.  
  961.     move.l    farea,D0
  962.     btst    #0,D0
  963.     beq    1$
  964.     bsr    stowbyte
  965.     move.l    farea,D0
  966. 1$
  967.     move.l    D0,A2
  968.     add.l    D3,A2
  969.     addq.l    #2,A2
  970.     cmp.l    #endsarea,A2
  971.     bcs    3$
  972. 2$    print    areafull
  973.     bra    reinterp
  974. 3$    move.l    D0,A0
  975.     move.w    D3,(A0)
  976.     move.l    A2,farea
  977.     RETURN    String
  978.  
  979.     DEF    dict
  980.     moveq    #-1,D4
  981.     bra    ..arry
  982.  
  983.     DEF    array
  984.     moveq    #0,D4
  985. ..arry
  986.     bsr    popnum
  987.     move.l    nextcode,A2
  988.     move.l    A2,A0
  989.     move.w    D0,(A2)+
  990.     add.l    D0,D0        bytes -> words
  991.     move.l    D0,D1
  992.     add.l    D1,D0
  993.     add.l    D1,D0        length * 3
  994.     tst.l    D4
  995.     beq    1$
  996.     add.l    D1,D0
  997.     add.l    D1,D0        length * 5
  998.     addq.l    #4,D0    +1 for null at end
  999.     move.l    A2,A0
  1000.     clr.w    (A2)+        current length is 0
  1001.     clr.l    (A2)            flag end
  1002. 1$    add.l    D0,A2
  1003.     cmp.l    #endcode,A2
  1004.     bls    2$
  1005.     ERR    codefull
  1006. 2$    move.l    A2,nextcode
  1007.     move.l    A0,D0
  1008.     tst.l    D4
  1009.     bne    3$
  1010.     RETURN    Array
  1011. 3$    RETURN    Dictionary
  1012.  
  1013.     DEF    fontalloc
  1014.     move.l    nextcode,A0
  1015.     lea    12(A0),A2
  1016.     cmp.l    #endcode,A2
  1017.     bls    1$
  1018.     ERR    codefull
  1019. 1$    move.l    A2,nextcode
  1020.     rts
  1021.  
  1022.  
  1023.     DEF    maxlength
  1024.     bsr    ipop
  1025.     move.l    D0,A0
  1026.     subq.l    #2,A0
  1027.     bra    ..lngth
  1028.  
  1029.     DEF    length
  1030.     bsr    ipop
  1031.     move.l    D0,A0
  1032.     cmp.w    #String,D2
  1033.     beq    ..rlngth
  1034.     cmp.w    #Array,D2
  1035.     beq    ..rlngth
  1036. ..lngth
  1037.     cmp.w    #Dictionary,D2
  1038.     bne    type_mismatch
  1039. ..rlngth
  1040.     moveq    #0,D0
  1041.     move.w    (A0),D0
  1042.     move.w    #Integer,D2
  1043.     bra    r.ipush
  1044.  
  1045.  
  1046. arrayref
  1047.     bsr    popnum
  1048.     move.l    D0,D1    the index
  1049.     bsr    ipop
  1050.     move.l    D0,A0    base of array
  1051.     moveq    #0,D3
  1052.     cmp.w    #Array,D2
  1053.     beq    1$
  1054.     cmp.w    #String,D2
  1055.     bne    type_mismatch
  1056. 1$    move.w    (A0)+,D3
  1057.     subq.l    #1,D3    length - 1 is max index
  1058.     bmi    3$
  1059.     cmp.l    D3,D1    past end?
  1060.     bhi    3$
  1061.     cmp.w    #Array,D2
  1062.     beq    2$
  1063.     add.l    D1,A0    ret not equal
  1064.     rts
  1065. 2$    add.l    D1,D1    word reference
  1066.     move.l    D1,D0
  1067.     add.l    D1,D0    times 3
  1068.     add.l    D1,D0
  1069.     add.l    D0,A0    index to element
  1070.     cmp.l    D0,D0
  1071.     rts
  1072. 3$    print    arr_err
  1073.     bra    reinterp
  1074.  
  1075.  
  1076.     DEF    get
  1077.     bsr    arrayref
  1078.     bne    1$
  1079.     move.w    (A0)+,D2    type
  1080.     move.l    (A0),D0    value
  1081.     bra    r.ipush
  1082. 1$    move.w    #Integer,D2
  1083.     moveq    #0,D0
  1084.     move.b    (A0),D0
  1085.     bra    r.ipush
  1086.  
  1087.     DEF    put
  1088.     bsr    ipop
  1089.     move.l    D0,-(SP)
  1090.     move.w    D2,-(SP)
  1091.     bsr    arrayref
  1092.     bne    1$
  1093.     move.w    (SP)+,(A0)+
  1094.     move.l    (SP)+,(A0)
  1095.     rts
  1096. 1$    move.w    (SP)+,D2
  1097.     move.l    (SP)+,D0
  1098.     cmp.w    #Integer,D2
  1099.     bne    type_mismatch
  1100.     move.b    D0,(A0)
  1101.     rts
  1102.  
  1103.     DEF    mark
  1104.     moveq    #0,D0
  1105.     RETURN    Mark
  1106.  
  1107.     DEF    rbracket
  1108.     moveq    #0,D3        count array elements
  1109. 1$    bsr    ipop
  1110.     cmp.w    #Mark,D2
  1111.     beq    2$
  1112.     addq.l    #1,D3
  1113.     move.l    D0,-(SP)
  1114.     move.w    D2,-(SP)
  1115.     bra    1$
  1116. 2$    move.l    nextcode,D0
  1117.     move.w    #Array,D2
  1118.     bsr    r.ipush
  1119.     move.l    D3,D0
  1120.     bsr    stowword
  1121.     bra    4$
  1122.  
  1123. 3$    move.w    (SP)+,D0
  1124.     bsr    stowword
  1125.     move.l    (SP)+,D0
  1126.     bsr    stowlong
  1127. 4$    dbra    D3,3$
  1128.     rts
  1129.  
  1130.  
  1131.     DEF    def
  1132.     bsr    ipop
  1133.     movem.l    D0/D2,-(SP)
  1134.     ARG    Name
  1135.     move.l    D0,A1    first check dict to see if old symbol
  1136.     move.l    D0,-(SP)    save for name of new entry
  1137.     bsr    alldictsearch
  1138.     move.l    (SP)+,D0
  1139.     tst.l    D2        found?
  1140.     bmi    newentry1
  1141. * replace old entry
  1142.     movem.l    (SP)+,D0/D2
  1143. *(perhaps change this so that when types don't match,
  1144. * make old entry nameless and create new entry, to prevent
  1145. * problem with previously compiled code)
  1146.     move.w    D2,(A2)+    new type
  1147.     move.l    D0,(A2)    new value
  1148.     rts
  1149.  
  1150. * called from findsym
  1151. newentry
  1152.     movem.l    D0/D2,-(SP)
  1153.     move.l    A0,D0
  1154. * make new entry
  1155. * type & value on stack; D0 -> name
  1156. newentry1
  1157.     move.w    dstackcnt,D1
  1158.     bne    4$
  1159.     move.l    nextentry,A0
  1160.     move.l    D0,(A0)+
  1161.     movem.l    (SP)+,D0/D2
  1162.     move.w    D2,(A0)+
  1163.     move.l    D0,(A0)+
  1164.     clr.l    (A0)
  1165.     cmp.l    #enddict,A0
  1166.     bhi    3$
  1167.     move.l    A0,nextentry
  1168.     rts
  1169. 3$    print    fulldict
  1170.     bra    reinterp
  1171. 4$    move.l    dstack,A0
  1172.     move.l    (A0),A0    address of dict -> current size
  1173.     move.w    -(A0),D1    D1 = maxsize
  1174.     addq.l    #2,A0    point at current size again
  1175.     cmp.w    (A0),D1        if max <= current, no room
  1176.     bls    3$
  1177.     moveq    #0,D1        form address for new entry
  1178.     move.w    (A0),D1
  1179.     add.l    D1,D1        word
  1180.     move.l    D1,D2    5 * new current size
  1181.     add.l    D1,D1
  1182.     add.l    D1,D1
  1183.     add.l    D2,D1
  1184.  
  1185.     addq.w    #1,(A0)+    new current size, & point to 1st entry
  1186.     add.l    D1,A0        point to new entry
  1187.     tst.l    (A0)            if not null, imp. error
  1188.     bne    imp_error
  1189.  
  1190.     move.l    D0,(A0)+
  1191.     movem.l    (SP)+,D0/D2
  1192.     move.w    D2,(A0)+
  1193.     move.l    D0,(A0)+
  1194.     clr.l    (A0)
  1195.  
  1196.     rts
  1197.  
  1198. alldictsearch
  1199.     move.l    dstack,A0
  1200.     move.w    dstackcnt,D3
  1201. 1$    subq.w    #1,D3
  1202.     bmi    3$
  1203.     move.l    (A0)+,A2
  1204.     addq.l    #2,A2    past current length
  1205.     movem.l    D3/A0,-(SP)
  1206.     bsr    dictsearch
  1207.     movem.l    (SP)+,D3/A0
  1208.     tst.l    D2
  1209. *    bmi    1$    (it was a mistake to search past top dictionary)
  1210.     rts
  1211. 3$    lea    systemdict,A2
  1212.     xdef    dictsearch
  1213. * A1 -> Name (bstr)
  1214. * A2 -> dict
  1215. * returns D2 = -1 if not found
  1216. *    else    D2 = type
  1217. *    D0 = value
  1218. *    A2 -> type in entry
  1219. dictsearch
  1220.     move.l    A1,-(SP)
  1221.     moveq    #0,D3        len
  1222.     move.l    D3,D2
  1223.     move.b    (A1)+,D3
  1224.     bsr    nextsym
  1225.     move.l    (SP)+,A1
  1226.     rts
  1227.  
  1228.  
  1229.     DEF    exch
  1230.     bsr    ipop
  1231.     move.l    D0,D1
  1232.     move.w    D2,D3
  1233.     bsr    ipop
  1234.     exg    D0,D1
  1235.     exg    D2,D3
  1236.     bsr    r.ipush
  1237.     move.l    D1,D0
  1238.     move.w    D3,D2
  1239.     bra    r.ipush
  1240.  
  1241.     DEF    dup
  1242.     bsr    ipop
  1243.     bsr    r.ipush
  1244.     bra    r.ipush
  1245.  
  1246.     DEF    true
  1247.     moveq    #-1,D0
  1248.     RETURN    Boolean
  1249.  
  1250.     DEF    false
  1251.     moveq    #0,D0
  1252.     RETURN    Boolean
  1253.  
  1254.     DEF    cvr
  1255.     ARG    Integer
  1256.     math    SPFlt
  1257.     RETURN    Real
  1258.  
  1259.     DEF    cvi
  1260.     ARG    Real
  1261.     math    SPFix
  1262.     RETURN    Integer
  1263.  
  1264. **************
  1265.  
  1266.     DEF    save
  1267.     lea    sstackcnt,A0
  1268.     cmp.w    #SstackSize,(A0)
  1269.     beq    1$
  1270.     addq.w    #1,(A0)
  1271.     move.l    sstack,A0
  1272.     move.l    farea,-(A0)
  1273.     move.l    nextentry,-(A0)
  1274.     move.l    nextcode,-(A0)
  1275.     move.l    A0,sstack
  1276.     bsr    _gsave
  1277.     moveq    #0,D0
  1278.     RETURN    Save
  1279. 1$    print    sstkov
  1280.     bra    reinterp
  1281.  
  1282.     DEF    restore
  1283.     ARG    Save
  1284.     lea    sstackcnt,A0
  1285.     tst.w    (A0)
  1286.     beq    1$
  1287.     subq.w    #1,(A0)
  1288.     move.l    sstack,A0
  1289.     move.l    (A0)+,nextcode
  1290.     move.l    (A0)+,A1
  1291.     clr.l    (A1)
  1292.     move.l    A1,nextentry
  1293.     move.l    (A0)+,farea
  1294.     bra    _grestore
  1295. 1$    print    sstkuv
  1296.     bra    reinterp
  1297.  
  1298.  
  1299. ****************
  1300.  
  1301. imp_error
  1302.     print    imperr
  1303.     bra    reinterp
  1304.  
  1305.     xdef    type_mismatch
  1306. type_mismatch
  1307.     print    mismatch
  1308.     bra    reinterp
  1309.  
  1310. *****************************
  1311.     section    three,bss
  1312.  
  1313. stacksave    ds.l    1
  1314.  
  1315. graphicsbase    ds.l    1
  1316. intuitionbase    ds.l  1
  1317. mathffpbase    ds.l    1
  1318. mathtransbase    ds.l  1
  1319.  
  1320. wbscreen    ds.l    1
  1321. rastport    ds.l    1
  1322.  
  1323. ohandle    ds.l    1
  1324. ihandle    ds.l    1
  1325.  
  1326.  
  1327. codearea    ds.w    CodeSize
  1328. endcode    ds.w    4
  1329.  
  1330. istack    ds.l    1
  1331.         ds.b    12
  1332. istackbot    ds.b    6*IstackSize
  1333. istacktop    ds.l    1
  1334.  
  1335. dstackcnt    ds.w    1
  1336. dstack        ds.l    1
  1337.         ds.b    8
  1338. dstackbot    ds.b    4*DstackSize
  1339. dstacktop    ds.l    1
  1340.  
  1341.  
  1342. sstackcnt    ds.w    1
  1343. sstack        ds.l    1
  1344.         ds.b    12
  1345. sstackbot    ds.b    12*SstackSize
  1346. sstacktop    ds.l    1
  1347.  
  1348. fsarea        ds.b    SAreaSize
  1349. endsarea    ds.b    2
  1350.  
  1351.     section two,data
  1352.  
  1353. farea        dc.l    fsarea
  1354. nextentry    dc.l    fdict
  1355. nextcode    dc.l    codearea
  1356. compilelevel    dc.w    0
  1357. parenlevel    dc.w    0
  1358.  
  1359.  
  1360.     bstr    underflow,<stack underflow>
  1361.     bstr    overflow,<stack overflow>
  1362.     bstr    areafull,<string area is full>
  1363.     bstr    mismatch,<type mismatch>
  1364.     bstr    nsv,<--nostringval-->
  1365.     bstr    fulldict,<dictionary is full>
  1366.     bstr    codefull,<code area is full>
  1367.     bstr    unknown,<unknown symbol>
  1368.     bstr    rbrace,<unmatched right brace>
  1369.     bstr    fperr,<floating point error>
  1370.     bstr    arr_err,<bad array reference>
  1371.     bstr    dstackov,<dict stack overflow>
  1372.     bstr    dstackuv,<dict stack underflow>
  1373.     bstr    imperr,<implementation error>
  1374.     bstr    sstkov,<save stack overflow>
  1375.     bstr    sstkuv,<save stack underflow>
  1376.  
  1377.     end
  1378.