home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / prolog / epro23.ark / VALGOL.PRO < prev   
Encoding:
Text File  |  1986-11-02  |  8.4 KB  |  344 lines
  1.  
  2. [
  3.    VALGOL.PRO
  4.    Compiler for VALGOL I -- ver. 2.2
  5.  
  6.    Written in E-Prolog.
  7.    Translates VALGOL I to ASM-compatible 8080 assembly language.
  8.     (Requires about 3000 bytes of string space.)
  9.  
  10.     See the May, 1985, issue of Dr. Dobb's Journal for an
  11.     explanation of this compiler.
  12.  
  13.     Written by: G. A. EDGAR    status: public domain
  14.  
  15. versions
  16.    0.3     September 9, 1984       M80, Z80, Micro-PROLOG
  17.    1.0     September 16, 1984      output for ASM
  18.    1.1     November 1, 1984        display input
  19.    1.2     November 10, 1984       version for DDJ
  20.    2.0     April 10, 1985          converted to E-Prolog
  21.    2.1     May 16, 1985            for E-Prolog ver. 2.0
  22.    2.2     August 1, 1985       version for SIG/M
  23.  
  24.    Usage:
  25.     (compile FOO BAR)    FOO.VAL -> BAR.ASM
  26.     (compile FOO)        FOO.VAL -> FOO.ASM
  27. ]
  28.  
  29.  
  30. [ ---------- Language independent part ---------------]
  31.  
  32. [ compile: input ?X, output ?Y]
  33. ((compile ?X) (compile ?X ?X))
  34. ((compile ?A:?X ?Y)(comp (?A:?X.VAL)(?Y.ASM)))
  35. ((compile ?X ?B:?Y)(comp (?X.VAL)(?B:?Y.ASM)))
  36. ((compile ?A:?X) (comp (?A:?X.VAL) (?A:?X.ASM)))
  37. ((compile ?X ?Y) (comp (?X.VAL) (?Y.ASM)))
  38. ((compile ?A:?X ?B:?Y) (comp (?A:?X.VAL)(?B:?Y.ASM)))
  39. ((comp ?infile ?outfile)
  40.     (message ?message) (WRITE ?message "^M^J")
  41.     (WRITE | ?infile) (WRITE " -> " | ?outfile) (WRITE "^M^J")
  42.     (open | ?infile)
  43.     (CREATE | ?outfile)
  44.     (readtoken ?token) (LESS ?dummy ?label)
  45.     (syntax ?syntax) (/) (Q (?token | ?label) ?after ?syntax)
  46.     (CLOSE) (OPEN CON)
  47.     (WRITE "^M^J** Compilation complete **^M^J") (/))
  48. ((comp | ?rest)
  49.     (CLOSE) (OPEN CON)
  50.     (WRITE "** Error detected **^M^J")(FAIL))
  51. ((open  | ?file)
  52.     (OPEN  | ?file))
  53. ((open  | ?file)
  54.     (WRITE "OPEN FAILURE ON " | ?file) (WRITE "^M^J") (FAIL))
  55. ((C | ?X)
  56.     (compile | ?X))
  57.  
  58. [ Q:  find it in the language-specific database]
  59. ((Q ?before ?after ?Z)
  60.     (?Z | ?X1) 
  61.     [ (WRITE "^M^J  Try " ?Z ?before) ]
  62.     (sequential ?before ?after | ?X1)
  63.     [ (WRITE "^M^J    Succeed " ?Z ?after) ]
  64.     )
  65. ((sequential ?position ?position))
  66. ((sequential ?position1 ?position3 (?z|?Z)|?rest)
  67.     (?z ?position1 ?position2|?Z) (/)
  68.     (sequential ?position2 ?position3|?rest))
  69.  
  70. [ out: send to outfile]
  71. ((out ?position ?position | ?data)
  72.     (WRITE | ?data))
  73.  
  74. [ readtoken: read a new token, watch for "."]
  75. ((readtoken ?token)
  76.     (READ ?token1) (readtokenx ?token1 ?token))
  77. ((readtokenx . (. | ?token2))
  78.     (READ ?token2))
  79. ((readtokenx ?token1 ?token1))
  80.  
  81. [ match: the input matches token]
  82. ((match ((. | ?token) | ?label) (?newtoken | ?label) . ?token)
  83.     (readtoken ?newtoken))
  84. ((match (?token | ?label) (?newtoken | ?label) ?token)
  85.     (readtoken ?newtoken))
  86. ((matchx ((. | ?token) | ?label) () . ?token))
  87. ((matchx (?token | ?label) () ?token))
  88.  
  89. [ empty: matches automatically]
  90. ((empty ?position ?position))
  91.  
  92. [ multiple: match the following zero or more times]
  93. ((multiple ?position1 ?position3|?Z)
  94.     (sequential ?position1 ?position2|?Z) (/)
  95.     (multiple ?position2 ?position3|?Z))
  96. ((multiple ?position ?position|?Z))
  97.  
  98. [ label: generate a new label]
  99. ((label (?token | ?label) (?token | ?newlabel) ?label)
  100.     (LESS ?label ?newlabel) (/))
  101.  
  102. [ string: match a string quoted within characters ']
  103. ((string (?token | ?label) (?newtoken | ?label) ?token)
  104.     (readtoken ?newtoken))
  105.  
  106. [ id: match an identifier]
  107. ((id (?token | ?label) (?newtoken | ?label) ?token)
  108.     (LESS @ ?token) (/) (readtoken ?newtoken))
  109.  
  110. [ number: match a number]
  111. ((number (0 | ?label) (?newtoken | ?label) 0)
  112.     (/) (readtoken ?newtoken))
  113. ((number (?token | ?label) (?newtoken | ?label) ?token)
  114.     (LESS 0 ?token) (/) (readtoken ?newtoken))
  115.  
  116.  
  117. [ --- VALGOL specifics ------------------------------ ]
  118.  
  119. ((message "VALGOL 1 compiler - translates VALGOL to ASM"))
  120. ((syntax PROGRAM))
  121.  
  122. ((PROGRAM
  123.     (match .begin)        (out
  124.                 "VCPM    EQU    0^M^J"
  125.                 "VBDOS    EQU    5^M^J"
  126.                 "VTPA    EQU    256^M^J"
  127.                 "VCR    EQU    13^M^J"
  128.                 "VLF    EQU    10^M^J"
  129.                 "    ORG    VTPA^M^J"
  130.                 "    LXI    SP,VSTACK^M^J")
  131.     (Q OPT-DECLARATION)
  132.     (Q STATEMENT)
  133.     (multiple
  134.         (match ;)
  135.         (Q STATEMENT))
  136.     (matchx .end)        (out
  137.                 "    JMP    VCPM^M^J"
  138.                 "VMULT:^M^J"
  139.                 "    MOV    B,H^M^J"
  140.                 "    MOV    C,L^M^J"
  141.                 "    XRA    A^M^J"
  142.                 "    MOV    H,A^M^J"
  143.                 "    MOV    L,A^M^J"
  144.                 "    MVI    A,16^M^J"
  145.                 "VMULT1:^M^J"
  146.                 "    PUSH    PSW^M^J"
  147.                 "    DAD    H^M^J"
  148.                 "    XRA    A^M^J"
  149.                 "    MOV    A,C^M^J"
  150.                 "    RAL^M^J"
  151.                 "    MOV    C,A^M^J"
  152.                 "    MOV    A,B^M^J"
  153.                 "    RAL^M^J"
  154.                 "    MOV    B,A^M^J"
  155.                 "    JNC    VMULT2^M^J"
  156.                 "    DAD    D^M^J"
  157.                 "VMULT2:^M^J"
  158.                 "    POP    PSW^M^J"
  159.                 "    DCR    A^M^J"
  160.                 "    ORA    A^M^J"
  161.                 "    JNZ    VMULT1^M^J"
  162.                 "    RET^M^J"
  163.                 "VEDIT:^M^J"
  164.                 "    MOV    A,H^M^J"
  165.                 "    ORA    L^M^J"
  166.                 "    JZ    VEDIT1^M^J"
  167.                 "    MVI    A,' '^M^J"
  168.                 "    CALL    VCPMOUT^M^J"
  169.                 "    DCX    H^M^J"
  170.                 "    JMP    VEDIT^M^J"
  171.                 "VEDIT1:^M^J"
  172.                 "    POP    H^M^J"
  173.                 "VEDIT2:^M^J"
  174.                 "    MOV    A,M^M^J"
  175.                 "    CPI    0^M^J"
  176.                 "    INX    H^M^J"
  177.                 "    JZ    VEDIT3^M^J"
  178.                 "    CALL    VCPMOUT^M^J"
  179.                 "    JMP    VEDIT2^M^J"
  180.                 "VEDIT3:^M^J"
  181.                 "    PUSH    H^M^J"
  182.                 "    RET^M^J"
  183.                 "VPRINT:^M^J"
  184.                 "    MVI    A,VCR^M^J"
  185.                 "    CALL    VCPMOUT^M^J"
  186.                 "    MVI    A,VLF^M^J"
  187.                 "    CALL    VCPMOUT^M^J"
  188.                 "    RET^M^J"
  189.                 "VCPMOUT:^M^J"
  190.                 "    PUSH    H^M^J"
  191.                 "    MOV    E,A^M^J"
  192.                 "    MVI    C,2^M^J"
  193.                 "    CALL    VBDOS^M^J"
  194.                 "    POP    H^M^J"
  195.                 "    RET^M^J"
  196.                 "    DS    60^M^J"
  197.                 "VSTACK:^M^J"
  198.                 "    END^M^J") ))
  199.  
  200. ((OPT-DECLARATION
  201.     (Q DECLARATION)
  202.     (match ;)))
  203. ((OPT-DECLARATION
  204.     (empty)))
  205.  
  206. ((DECLARATION
  207.     (match .integer)        (label ?label1)
  208.                 (out    "    JMP    V" ?label1 "^M^J")
  209.     (Q ID-SEQUENCE)        (out    "V" ?label1 ":^M^J") ))
  210.  
  211. ((ID-SEQUENCE
  212.     (Q IDENTIFIER)
  213.     (multiple
  214.         (match ,)
  215.         (Q IDENTIFIER) )))
  216.  
  217. ((IDENTIFIER
  218.     (id ?identifier)        (out   ?identifier "V:    DS    2^M^J") ))
  219.  
  220. ((STATEMENT
  221.     (Q BLOCK)))
  222. ((STATEMENT
  223.     (Q UNTIL-STATEMENT)))
  224. ((STATEMENT
  225.     (Q CONDITIONAL-STATEMENT)))
  226. ((STATEMENT
  227.     (Q IO-STATEMENT)))
  228. ((STATEMENT
  229.     (Q ASSIGNMENT-STATEMENT)))
  230.  
  231. ((BLOCK
  232.     (match .begin)
  233.     (Q BLOCKBODY)))
  234. ((BLOCKBODY
  235.     (Q DECL-OR-ST)
  236.     (multiple
  237.         (match ;)
  238.         (Q STATEMENT) )
  239.     (match .end) ))
  240. ((BLOCKBODY
  241.     (match .end) ))
  242.  
  243. ((DECL-OR-ST
  244.     (Q DECLARATION)))
  245. ((DECL-OR-ST
  246.     (Q STATEMENT)))
  247.  
  248. ((IO-STATEMENT
  249.     (match edit)
  250.     (match "(")
  251.     (Q EXPRESSION)
  252.     (match ,)
  253.     (string ?Z)            (out    "    CALL    VEDIT^M^J")
  254.                 (out    "    DB    '" ?Z "',0^M^J")
  255.     (match ")") ))
  256. ((IO-STATEMENT
  257.     (match print)        (out    "    CALL    VPRINT^M^J") ))
  258.  
  259. ((CONDITIONAL-STATEMENT
  260.     (match .if)            (label ?label1) (label ?label2)
  261.     (Q EXPRESSION)
  262.     (match .then)        (out    "    MOV    A,H^M^J")
  263.                 (out    "    ORA    L^M^J")
  264.                 (out    "    JZ    V" ?label1 "^M^J")
  265.     (Q STATEMENT)
  266.     (match .else)        (out    "    JMP    V" ?label2 "^M^J")
  267.                 (out    "V" ?label1 ":^M^J")
  268.     (Q STATEMENT)        (out    "V" ?label2 ":^M^J") ))
  269.  
  270. ((UNTIL-STATEMENT
  271.     (match .until)        (label ?label1) (label ?label2)
  272.                 (out    "V" ?label1 ":^M^J")
  273.     (Q EXPRESSION)
  274.     (match .do)            (out    "    MOV    A,H^M^J")
  275.                 (out    "    ORA    L^M^J")
  276.                 (out    "    JNZ    V" ?label2 "^M^J")
  277.     (Q STATEMENT)        (out    "    JMP    V" ?label1 "^M^J")
  278.                 (out    "V" ?label2 ":^M^J") ))
  279.  
  280. ((ASSIGNMENT-STATEMENT
  281.     (Q EXPRESSION)
  282.     (match =)(match :)
  283.     (id ?identifier)        (out    "    SHLD    " ?identifier "V^M^J") ))
  284.  
  285. ((EXPRESSION
  286.     (Q EXPRESSION1)
  287.     (Q OPT-RIGHT-SIDE)))
  288.  
  289. ((OPT-RIGHT-SIDE
  290.     (match .=)            (label ?label1) (label ?label2)
  291.                 (out    "    PUSH    H^M^J")
  292.     (Q EXPRESSION1)        (out
  293.                 "    POP    D^M^J"
  294.                 "    MOV    A,L^M^J"
  295.                 "    SUB    E^M^J"
  296.                 "    JNZ    V" ?label2 "^M^J"
  297.                 "    MOV    A,H^M^J"
  298.                 "    SBB    D^M^J"
  299.                 "    JNZ    V" ?label2 "^M^J"
  300.                 "    LXI    H,1^M^J"
  301.                 "    JMP    V" ?label1 "^M^J"
  302.                 "V" ?label2 ":^M^J"
  303.                 "    LXI    H,0^M^J"
  304.                 "V" ?label1 ":^M^J") ))
  305. ((OPT-RIGHT-SIDE
  306.     (empty)))
  307.  
  308. ((EXPRESSION1
  309.     (Q TERM)
  310.     (multiple
  311.         (Q SIGNED-TERM))))
  312.  
  313. ((SIGNED-TERM
  314.     (match +)            (out    "    PUSH    H^M^J")
  315.     (Q TERM)            (out    "    POP    D^M^J")
  316.                 (out    "    DAD    D^M^J")))
  317. ((SIGNED-TERM
  318.     (match -)            (out    "    PUSH    H^M^J")
  319.     (Q TERM)            (out
  320.                 "    POP    D^M^J"
  321.                 "    MOV    A,E^M^J"
  322.                 "    SUB    L^M^J"
  323.                 "    MOV    L,A^M^J"
  324.                 "    MOV    A,D^M^J"
  325.                 "    SBB    H^M^J"
  326.                 "    MOV    H,A^M^J")  ))
  327.  
  328. ((TERM
  329.     (Q PRIMARY)
  330.     (multiple
  331.         (match *)        (out    "    PUSH    H^M^J")
  332.         (Q PRIMARY)        (out    "    POP    D^M^J")
  333.                 (out    "    CALL    VMULT^M^J") )))
  334.  
  335. ((PRIMARY
  336.     (id ?identifier)        (out    "    LHLD    " ?identifier "V^M^J")))
  337. ((PRIMARY
  338.     (number ?number)        (out    "    LXI    H," ?number "^M^J")))
  339. ((PRIMARY
  340.     (match "(")
  341.     (Q EXPRESSION)
  342.     (match ")") ))
  343.  
  344.