.z80
;****************************************
;* Strukta Compiler   Version 1.4       *
;* written in Strukta                   *
;* by Rolf-Dieter Klein   1983 8.1.83   *
;* Copyright  1983 (C)                  *
;* 8000 Muenchen 40                     *
;* Strassbergerstr. 34                  *
;* West Germany                         *
;* Tel (089) 3519416                    *
;****************************************



jp start	;start of main program
		;jump also done by linker
		;if l80 is used


; -constant declaration----------------------------------------

seper  equ 21h	;character for more cmds on one line
seper1 equ 7ch	;same as above may not apear in the program
		;neither as comment or string if not
		;a real seperator
maxchar equ 256	;max characters per line not greater than 256


; --------------------------------------------------------------


bdos equ 5	;Bdos Start
;
true equ 1
false equ 0

; constants 
; for the tables key,key1,sym1
; must be in the same sequenze
; three tables affected on change
; symbols,tabcase and keyfield 
; all must be in same order
;
; key
;
ifsymbol equ 0	;
elseifsymbol equ 1
elsesymbol equ 2
endifsymbol equ 3
repeatsymbol equ 4
untilsymbol equ 5
whilesymbol equ 6
endwhilesymbol equ 7
loopsymbol equ 8
endloopsymbol equ 9
exitifsymbol equ 10
exitsymbol equ 11
dosymbol equ 12
enddosymbol equ 13
assembly equ 14
;
; key1
zero equ 0
carry equ 1
pareven equ 2
positive equ 3
overflow equ 4
nooverflow equ 5
minus equ 6
parodd equ 7
nocarry equ 8
nonzero equ 9
nocond equ 10
;

; order of following symbols is important
; key2
bcreg equ 0
dereg equ 1
hlreg equ 2
spreg equ 3
ixreg equ 4
iyreg equ 5
areg equ 6	;akku important
breg equ 7
creg equ 8
dreg equ 9
ereg equ 10
hreg equ 11
lreg equ 12
noeg equ 13
;

bcpair equ bcreg+32
depair equ dereg+32
hlpair equ hlreg+32
sppair equ spreg+32
ixpair equ ixreg+32
iypair equ iyreg+32
;
null equ 64	;value of zero
const equ 65	;std constant
name equ 66	;name
char equ 67	;string with one element
string equ 68	;more characters
syntax equ 69	;nothing rec
;




; key 3
odersym equ 0
undsym equ 1
notsym equ 2
insym equ 3
nokey3 equ 4



; sym2
jpaus equ 0
jraus equ 1
retaus equ 2
callaus equ 3
;
; sym3
notequal equ 0
lessequal equ 1
greatequal equ 2
equal equ 3
less equ 4
greater equ 5
nocomp equ 6

;
; makros
prtstr macro text
 local marke,marke1
 ld iy,marke1
 call prt1str
 jr marke
 marke1:
  defm text
  defb 0
 marke: 
 endm
;

error macro text
 local marke3,marke4
 push hl
 ld hl,marke3
 call errein
 pop hl
 jr marke4
 marke3:
 defm text
 defb 0
 marke4:
 endm


;
echo::		;
push hl		;get one character from the Console
push de		;Device
push bc
ld c,1
call bdos
pop bc
pop de
pop hl
ret		;result in Akku

;
co::		;put one Character to Console Device
push hl		;value is in register c
push de		;
push bc
ld e,c
ld c,2		;function co
call bdos
pop bc
pop de
pop hl
ld a,c		;akku=character
ret
;
lo::
push hl
push de
push bc
ld e,c
ld c,5
call bdos
pop bc
pop de
pop hl
ld a,c
ret
;

; disksubprogramms
;
open::		;open a file 
		;de -> fcb
 ld c,0fh	;openfunction
 call bdos
ret		;a=code

make::		;create a file
 ld c,16h
 call bdos	;de -> fcb
ret


erase::		;delete file
 ld c,13h
 call bdos
ret


close::
 ld c,10h	;close
 call bdos	;de -> fcb
ret		;a=code

;
setdma::
 ld c,1ah	;set dma adress
 call bdos	;de = adress
ret
;

readsq::
 ld c,14h	;read sequencial
 call bdos	;de -> fcb
ret

writesq::
 ld c,15h	;write sequencial
 call bdos	;de -> fcb
ret


txter1::
defm 'FILE NOT FOUND'
defb 0dh,0ah,0

txter2::
defm 'DIRECTORY FULL'
defb 0dh,0ah,0
;
txter3::
defm 'DISK FULL'
defb 0dh,0ah,0


;
initflop::	;define buffers
		;clear 
		;both fcbs are valid
		;carry if error detected
ld de,fcbread
call open
if a=255
 ld hl,txter1
 call print
 scf 
 exit
endif
ld a,(iodest)
if a=1
 ld de,fcbwrite
 call erase
 ld de,fcbwrite	;create new one
 call make
 if a=255 
  ld hl,txter2
  call print
  scf
  exit
 endif
endif
; ok new one there
ld hl,4096	;to end
ld (rbuflen),hl	;undefined
ld hl,0		;empty
ld (wbuflen),hl	;
ld hl,wbuf	;clear buffers
ld de,wbuf+1
ld bc,4096-1
ld (hl),1ah	;CTRL Z
ldir
scf
ccf
ret

rdflop::	;get one char to akku
		;carry if eof
		;save all registers
push hl
push de
push bc
ld hl,(rbuflen)	;if equal 4096 then empty
ld de,4096
xor a
sbc hl,de
ld a,l
or h
if nz		;not empty
 ld de,(rbuflen)
 ld hl,rbuf	;start of buffer
 add hl,de
 ld a,(hl)	;new value
 inc de
 ld (rbuflen),de ;new length
else		;empty first read all
		;new sektors
 ld hl,rbuf	;clear to CTRL Z
 ld de,rbuf+1
 ld bc,4096-1
 ld (hl),1ah	;clear
 ldir
 ld hl,rbuf
 ld d,32	;count of sektors if possible to read
 do d
  push hl
  push de
  ex de,hl
  call setdma	;to hl
  ld de,fcbread
  call readsq	;also if a<>0 doesnt matter
  pop de
  pop hl
  ld bc,128
  add hl,bc
 enddo
 ld hl,1	;first char readin
 ld (rbuflen),hl
 ld a,(rbuf)	;
endif
pop bc
pop de
pop hl
scf
ccf
ret


wrflop::	;put char c to flop
		;carry if error
push hl		;c = value
push de
push bc
ld hl,(wbuflen)	;look if space
ld de,4096
xor a
sbc hl,de
ld a,l
or h
if a<>0		;ok space
 ld hl,wbuf
 ld de,(wbuflen)
 add hl,de
 ld (hl),c	;write it
 inc de
 ld (wbuflen),de
else		;write first
 push bc
 ld hl,wbuf
 ld d,32	;all sectors
 do d
  push hl
  push de
  ex de,hl
  call setdma
  ld de,fcbwrite
  call writesq	;a<>0 is error FATAL
  pop de
  pop hl
  if a<>0
   ld hl,txter3
   call print
   ld a,0
   ld (iodest),a	;switch to console
   scf		;leave it
  endif
  ld bc,128
  add hl,bc
 enddo
 ld hl,wbuf	;clear it
 ld de,wbuf+1
 ld bc,4096-1
 ld (hl),1ah
 ldir
 pop bc		;get char
 ld hl,1	;one writen
 ld (wbuflen),hl
 ld a,c
 ld (wbuf),a	;to first position CHARACTER
endif
pop bc
pop de
pop hl
scf
ccf
ret

;


terminate::	;end of sequenz write restbuffer
		;back and close files
ld de,(wbuflen)	;write back until 0
		;calculate number of sektors
ld a,d
or e
if nz		;then anything there
 ld a,e
 rlca
 rl d		;to d
 res 7,e	;reset the msb
 ld a,d		;get msb
 and 3fh	;savety
 ld d,a		;count of sektors
 ld a,e
 if a<>0
  inc d		;number count exact
 endif		;d = 1..32
 ld hl,wbuf	;start adresse
 do d		;count of loop
  push hl
  push de
  ex de,hl	;de new dma
  call setdma
  ld de,fcbwrite    
  call writesq	;and write it
  pop de
  pop hl
  if a <> 0
   ld hl,txter3
   call print
   scf 
   exit		;ERROR EXIT
  endif
  ld bc,128
  add hl,bc	;next adress
 enddo
endif
ld de,fcbread
call close
ld de,fcbwrite
call close	;ok both are closed
scf
ccf
ret


;


getcha::	;get one character to akku
ld a,(eof)
if a=1
 ld a,1ah	;stop if eof
 exit
endif
ld a,(iosrc)
if a=0
 call echo	;get from console
 if a=0dh	;echo a linefeed
  ld c,0ah
  call co
  ld a,0dh
 endif
 if a=1ah
  ld a,1
  ld (eof),a	;set eof as marker
  ld a,1ah
  scf		;stop carry = CTRL Z
 else
  scf		;no carry means ok s.o.
  ccf
 endif
else
 ; floppy
 call rdflop	;carry means error,ctlr z
 if a=1ah
  ld a,1
  ld (eof),a
  ld a,1ah	;CTRL Z terminates all
 endif
endif
ret

putcha::
ld a,(iodest)
if a=0 or a=2
 if c=9
  ld a,(tabcnt)
  ld c,a
  ld a,8
  sub c		;8 - n (0..7)
  ld c,a
  do c
   push bc
   ld c,' '
   ld a,(iodest)
   if a=0
    call co
   else
    call lo
   endif
   pop bc
  enddo  
  ld a,0
  ld (tabcnt),a	;restore
 else
  push bc
  ld a,(iodest)
  if a=0
   call co	;to outputstream from reg c
  else
   call lo
  endif
  pop bc
  ld a,(tabcnt)
  inc a
  if a = 8	;0..7
   ld a,0
  endif
  ld (tabcnt),a	;0..7  0..7
  if c = 0dh or c =0ah
   xor a
   ld (tabcnt),a
  endif
 endif
 scf
 ccf		;no carry means ok
else
 ; floppy 
 call wrflop	;including error exit
endif
ret
;


print::		;output message to console
while (hl)<>0	;termintor is \0
 ld c,(hl)
 call co
 inc hl
endwhile
ret
;

dezout::	;print hl in dezimal
ld c,0		;save flag on stack
push bc		;allways positive
repeat
 ld a,0		; hl := hl div 10
 do b,16	; a := hl mod 10
  sla l
  rl h
  rl a
  cp 10		; div 10
  if nc
   sub 10
   set 0,l
  endif
 enddo
 add a,'0'
 ld c,a
 push bc
until h=0 and l=0
pop bc
while c<>0
 call co	;to console only
 pop bc
endwhile
ret
;

dezix::		;hl to (ix) in dezimal
		;terminate with 0
ld c,0		;save flag on stack
push bc		;allways positive
repeat
 ld a,0		; hl := hl div 10
 do b,16	; a := hl mod 10
  sla l
  rl h
  rl a
  cp 10		; div 10
  if nc
   sub 10
   set 0,l
  endif
 enddo
 add a,'0'
 ld c,a
 push bc
until h=0 and l=0
pop bc
while c<>0
 ld (ix+0),c
 inc ix
 pop bc
endwhile
ld (ix+0),0
ret
;


getline::	;get one  line from the input stream
 ld hl,einzeile	;point to start of the line
 ld b,0		;char counter
 repeat
  repeat
   call getcha	;carry = final
  until c or a <> 0ah
  if a <> 1ah	;ctrl Z
   if a = 8	;backspace
    if b<>0
     dec hl 
     dec b
     push bc
     ld c,' '
     call co
     ld c,8
     call co
     pop bc
     ld a,' '	;dummy
    endif
   else
    if a = 0dh or a = seper or a=seper1 ;end of line
     ld (hl),0	;terminator
     ld c,0dh	;end
    else
     if a < 32
      ld a,' '
     endif
     ld (hl),a
     ld c,a
     inc hl
     inc b
    endif
   endif
   scf
   ccf
  else
   ld c,1ah	;stop it
  endif
 until c=1ah or c = 0dh or b=maxchar-2
 ld (hl),0	;savety
 ld hl,(inline)
 inc hl
 ld (inline),hl	;
 ;only if not console
 ld a,(iosrc)
 if a<>0
  ld a,l
  and 7fh	;every 128 lines
  if a=0
   ld c,'.'
   call co	;show that it works every 128 lines
  endif		;lines
 endif
ret
;

;
putline::		;auszeile to output device
			;count global line-counter
			;check whether line is empty
			;if so then do not output
push bc			;save all
push de	
push hl			;save hl is important
ld hl,auszeile		;start of line
ld a,0
ld (flagp),a		;assume no char there
while (hl) <> 0
 if not (hl) in [32,9]
  ld a,1
  ld (flagp),a
 endif
 inc hl
endwhile
ld a,(flagp)		;must be comment mode
ld b,a			;if comments or chars
ld a,(comsw)		;1=nocomments
if a=0 or b=1		;ok line is valid
 ld hl,(outline)
 inc hl
 ld (outline),hl
 ld hl,auszeile		;output of the line
 while (hl) <> 0 
  ld c,(hl)
  call putcha		;print it
  inc hl
 endwhile
 ld c,0dh
 call putcha
 ld c,0ah
 call putcha		;and print crlf
endif
pop hl
pop de
pop bc
ret
;


toupper::		;convert to uppercase
if a in ['a'..'z']
 sub 'a'
 add a,'A'
endif
ret
;

blank equ 0	;state names
z1 equ 1
zb equ 2
z2 equ 3
z3 equ 4
komm equ 5
;


sepline::	;calculate values of labelx,instr,comment
xor a
ld (lenlab),a
ld (lenins),a
ld (lencom),a	;all undefined
;
ld a,blank
ld (state),a	;set to first state
ld hl,einzeile	;pointer to einzeile
while (hl)<>0	;as long as not empty
 ld c,(hl)	;value of char hl=pointer
 ld a,(state)
 if a = blank 
  if c = 3bh
   ld a,komm
   ld (state),a	;set to comment state
   ld (comment),hl
   ld a,1
   ld (lencom),a
  else
   if c <> ' '
    ld a,z1
    ld (state),a
    ld (instr),hl ; set to first value
    ld a,1
    ld (lenins),a ; one char valid
   endif
  endif
 else
  if a = z1
   if c = 3bh
    ld a,komm
    ld (state),a
    ld (comment),hl
    ld a,1
    ld (lencom),a
   else
    ld a,(lenins)
    inc a
    ld (lenins),a ; next point valid
    if c = ':'
     ld a,zb
     ld (state),a
     ld de,(instr)
     ld (labelx),de
     ld a,(lenins)
     ld (lenlab),a
     ld a,0
     ld (lenins),a ;was label
    else
     if c=22h or c=27h 
      ld a,z2
      ld (state),a
     else
      if c=' ' ;nach blanks keine labels
       ld a,z3
       ld (state),a
      endif
     endif
    endif
   endif
  else 
   if a = zb
    if c = 3bh
     ld a,komm
     ld (state),a
     ld (comment),hl
     ld a,1
     ld (lencom),a
    else
     if not c in [' ',':']
      ld a,z3
      ld (state),a
      ld (instr),hl ;start value
      ld a,1
      ld (lenins),a
     else
      if c = ':'
       ld a,(lenlab)
       inc a
       ld (lenlab),a
      endif
     endif
    endif
   else
    if a = z2
     ld a,(lenins)
     inc a
     ld (lenins),a
     if c = 22h or c = 27h
      ld a,z3
      ld (state),a
     endif
    else
     if a = z3
      if c = 3bh 
       ld a,komm
       ld (state),a
       ld (comment),hl
       ld a,1
       ld (lencom),a
      else
       ld a,(lenins)
       inc a 
       ld (lenins),a
       if c = 22h or c = 27h
        ld a,z2
        ld (state),a
       endif
      endif
     else
      if a = komm
       ld a,(lencom)
       inc a
       ld (lencom),a
      endif
     endif
    endif
   endif 
  endif
 endif
 inc hl		;next char
endwhile
; transport to sourcelin
ld hl,(instr)
ld de,sourcelin
ld a,(lenins)
ld b,a
if b<>0
 do b
  ld a,(hl)
  ld (de),a
  inc hl
  inc de
 enddo
endif
xor a
ld (de),a	;mark end
ret

trf::		;small transport
while b <> 0
 ld a,(hl)	;get source
 ld (ix+0),a
 inc hl
 inc ix
 dec b
endwhile
ret
;


toaus::		;fuer std ausgabe aufbereiten
		;output of labelx,instr,comment
		;to the string auszeile
ld ix,auszeile	;pointer to destination
ld hl,(labelx)
ld a,(lenlab)	;if label
ld b,a
call trf
;
toaus1::
ld hl,(instr)
ld a,(lenins)
ld b,a
ld a,(lencom)
if a<>0 or b<>0
 ld (ix+0),9
 inc ix
endif
call trf
ld hl,(comment)
ld a,(comsw)
if a=0
 ld a,(lencom)
 ld b,a
 if a<>0
  ld (ix+0),9
  inc ix
 endif
 call trf	;if nonzero
endif
ld (ix+0),0	;terminator
call putline
ret

;


getkey::	;ix -> key table
		;de -> start of text to be compared
		;c=counter of valid chars
		;scans until no alpha or digit
		;----
		;carry if no key found a=nmax+1
		;else a=n (0..n) of keynumber
		;de points to nextsymbol
		;if found else to start
ld (de1sto),de
ld (bc1sto),bc	;save it
call igbn	;ignore and count
push ix
ld (desto),de	;temp sto
ld (bcsto),bc
exx
ld b,0		;index counter
exx
loop
 if (ix+0)=0	;terminator search useless
  ld de,(de1sto) ;get old one
  ld bc,(bc1sto) ;get counter old one
  scf
  exit
 endif
 ld a,(de)
 call toupper
 if (ix+0)=a	;if both equal then  suspect
  ld a,(de)
  call toupper
  ld b,a
  while (ix+0)=b and (ix+0)<>0 and b<>0
   inc ix
   inc de
   inc c	;char counter
   ld a,(de)
   call toupper
   ld b,a
  endwhile
  if not b in ['a'..'z','A'..'Z','0'..'9']
   if (ix+0)=0
    scf
    ccf		;ok key found de-> next
    exit
   endif
  endif
  ld de,(desto)	;get old pointer back
  ld bc,(bcsto)	;old char counter
 endif
 ; search next keyword
 while (ix+0) <> 0
  inc ix
 endwhile
 inc ix		;to next keyword 
 exx
 inc b		;next number
 exx
endloop
pop ix
exx
ld a,b		;number , de->nextsymbol
exx
ret

getsym::	;ix -> key table
		;de -> start of text to be compared
		;scans until found or 0 for spez symbols
		;order of keytab is important because
		;the first symbols are taken
		;----
		;carry if no key found a=nmax+1
		;else a=n (0..n) of keynumber
		;de points to nextsymbol
ld (de1sto),de
ld (bc1sto),bc	;save it
call igbn	;ignore and count
push ix
ld (desto),de	;temp sto
ld (bcsto),bc
exx
ld b,0		;index counter
exx
loop
 if (ix+0)=0	;terminator search useless
  ld de,(de1sto) ;get old one
  ld bc,(bc1sto) ;get counter old one
  scf
  exit
 endif
 ld a,(de)
 call toupper
 if (ix+0)=a	;if both equal then  suspect
  ld a,(de)
  call toupper
  ld b,a
  while (ix+0)=b and (ix+0)<>0 and b<>0
   inc ix
   inc de
   inc c	;char counter
   ld a,(de)
   call toupper
   ld b,a
  endwhile
  if (ix+0)=0
   scf
   ccf		;ok key found de-> next
   exit
  endif
  ld de,(desto)	;get old pointer back
  ld bc,(bcsto)	;old char counter
 endif
 ; search next keyword
 while (ix+0) <> 0
  inc ix
 endwhile
 inc ix		;to next keyword 
 exx
 inc b		;next number
 exx
endloop
pop ix
exx
ld a,b		;number , de->nextsymbol
exx
ret


; all string functions terminate the string with 0
; but they do not inr ix so that the can be concatenated
; easyly

;
putlabel::	;ix -> destination hl = labelnr
push bc
push de
push hl
ld (ix+0),'.'
inc ix
ld (ix+0),'L'
inc ix
call dezix	;dezimalnumber to ix ok term
pop hl
pop de
pop bc
ret		;ix points to next free place

lblsgn::	;label marker '.Lnnnn:'
ld (ix+0),':'
inc ix
ld (ix+0),0
ret


; used by makro
prt1str::	;iy -> string fixed
		;ix -> destination
while (iy+0) <> 0
 ld a,(iy+0)
 ld (ix+0),a
 inc ix
 inc iy
endwhile
ld (ix+0),0
ret

;

prtind::	;ix -> ziel a=index iy -> keytabelle
push bc
ld b,a		;range 0..n
loop
 exitif b=0	;index found
 while (iy+0)<>0
  inc iy
 endwhile
 inc iy		;next pos
 exitif (iy+0)=0
 dec b		;count backwards
endloop
while (iy+0) <> 0
 ld a,(iy+0)
 ld (ix+0),a
 inc ix
 inc iy
endwhile
pop bc
ld (ix+0),0
ret


prttab::	;set tab
 ld (ix+0),9
 inc ix
 ld (ix+0),0
ret

prtchl::	;print c chars from (hl)
		;save all registers
		;without ix
		;print them to (ix)
		;if c umlimited then print 
		;till 0 in inputstream
push hl
push bc
 while c <> 0 and (hl) <> 0
  ld a,(hl)
  ld (ix+0),a
  inc ix
  inc hl
  dec c
 endwhile
pop bc
pop hl
ld (ix+0),0	;terminate string
ret
;

;


;

gencomment::	;set commentline hl=levelnumber
		;destination is auszeile
ld hl,(level)	;get level
push hl
ld ix,auszeile	;pointer to destination
ld hl,(labelx)
ld a,(lenlab)	;if label
ld b,a
call trf
pop hl
ld a,(comsw)
if a=0
 ld (ix+0),';'	;new comment
 inc ix
 call dezix	;output number
 ld (ix+0),' '
 inc ix
 call toaus1	;rest std
else
 ld (ix+0),0	;no comment
 call putline	;
endif
ret
;


; scanner fuer assemblerausdruecke
; scanner for assemby expressions
;
;
; de -> points to start of text to be analysed
; afterwards
; de -> points to nextsymbol not in syntax
; b = recogniced typ
; c = count of read characters including blanks
;


igbn::		;ignore blanks subprogram
ld a,(de)
while a=' '
 inc de
 inc c		;also increment counter
 ld a,(de)
endwhile
ret


scanass::	;scan assembly syntax restricted
push ix
ld c,0		;0 characters read in
call igbn	;ignore leading blanks
call scan1	;processor for symbols
pop ix		;de points to next symbol b,c valid
ret		;b=code c=count of read in chars

scan1::		;sub utility
ld b,syntax	;assume syntax error
ld a,(de)	;get first symbol
if a=27h	;was it a quote
 inc de		;ok start symbol
 inc c		;one char
 ld a,(de)
 if a=27h or a=2 ;error if again quot
  ld b,syntax
  exit
 endif
 inc de
 inc c
 ld b,char	;seams to be char
 ld a,(de)
 while a<>27h and a<>0	;end char
  inc de
  inc c
  ld b,string	;must be string
  ld a,(de)
 endwhile
 inc de
 inc c		;to next symbol
 call igbn	;next symbol + or -
 ld a,(de)
 if a in ['+','-']
  inc de
  inc c
  call scan1	;RECURSIVE
  if b in [null,const,name,char,string]
   ld b,const	;always constant
  else
   ld b,syntax	;else is error
  endif
 endif
else
 if a=22h	;quote
  inc de		;ok start symbol
  inc c		;one char
  ld a,(de)
  if a=22h or a=2 ;error if again quot
   ld b,syntax
   exit
  endif
  inc de
  inc c
  ld b,char	;seams to be char
  ld a,(de)
  while a<>22h and a<>0	;end char 
   inc de
   inc c
   ld b,string	;must be string
   ld a,(de)
  endwhile
  inc de
  inc c		;to next symbol
  call igbn	;next symbol + or -
  ld a,(de)
  if a in ['+','-']
   inc de
   inc c
   call scan1	;RECURSIVE
   if b in [null,const,name,char,string]
    ld b,const	;always constant
   else
    ld b,syntax	;else is error
   endif
  endif
 else 	; check for simple register 
  if a = '('
   inc de
   inc c
   ld ix,key2
   call getkey	;check for register
   if a in [ixreg,iyreg]
    add a,32
    ld b,a	;save it
    call igbn
    ld a,(de)
    if a = '+' ; ok when + constant
     inc de
     inc c
     call igbn
     ld a,(de)
     while a in ['0'..'9','a'..'z','A'..'Z','+','-']
      inc de
      inc c
      ld a,(de)
     endwhile
    else
     ld b,syntax
     exit	;error cond
    endif
   else
    if a in [areg..lreg]
     ld b,syntax ;not possible
    else
     add a,32	;must conform regspec
     ld b,a
    endif
   endif
   call igbn
   ld a,(de)	;must be )
   if a = ')'
    inc de
    inc c
   else
    ld b,syntax
   endif
  else 	;simple register
   ld ix,key2	;keywords register
   call getkey	;de stays valid c count up 
   if a = noeg
    ; must be constant de-> start without blanks
    ld a,(de)
    if a in ['0'..'9']
     ; is number check whether zero
     ld a,0
     ld (flag),a ;assume zero
     ld a,(de)
     while a in ['0'..'9','A'..'F','a'..'f','h','H','O','o','B','b']
      if not a in ['H','h','O','o','0']
       ld a,1	;binary bB 0b is not zero
       ld (flag),a
      endif
      inc de
      inc c
      ld a,(de)
     endwhile
     ld a,(flag)
     if a=0
      ld b,null
     else
      ld b,const 
     endif
     call igbn	;next symbol + or -
     ld a,(de)
     if a in ['+','-']
      inc de
      inc c
      call scan1	;RECURSIVE
      if b in [null,const,name,char,string]
       ld b,const	;always constant
      else
       ld b,syntax	;else is error
      endif
     endif
    else ; is name    
     ld a,(de)
     if a in ['0'..'9','a'..'z','A'..'Z']
      while a in ['0'..'9','a'..'z','A'..'Z']
       inc de
       inc c
       ld a,(de)
      endwhile
      ld b,name	;is a name
      call igbn
      ld a,(de)
      if a in ['+','-']
       inc de
       inc c
       call scan1	;recursive
       if b in [null,const,name,char,string]
        ld b,const
       else		;register etc
        ld b,syntax
       endif
      endif
     endif	;no name because blanks only
    endif
   else 	;must be single register
    ld b,a	;save code all valid, register
   endif
  endif
 endif
endif
; ok final b is valid
ret



reverse::	;a=code of condition
		;result is complementary condition
push bc		;preserve all registers
push hl
ld c,a		;save for compare
ld hl,tabrev
loop
 exitif (hl)=0ffh ;end of table
 if (hl)=c
  inc hl
  ld a,(hl)
  exit
 endif
 inc hl		;by two
 inc hl
endloop
pop hl
pop bc
ret


tabrev::
defb zero,nonzero
defb carry,nocarry
defb pareven,parodd
defb positive,minus
defb overflow,nooverflow
defb nooverflow,overflow
defb minus,positive
defb parodd,pareven
defb nocarry,carry
defb nonzero,zero
defb nocond,nocond
defb 0ffh,0ffh	;terminator

;
; LABEL GENERATOR
;

newlabel::	;get next label to hl
ld hl,(labelnr)
inc hl
ld (labelnr),hl
ret



gencode::	;main sub codegenerator
		;for small conditions  
		;a = tf true = 1 false = 0
		;b = type of jump sym2
		;c = type of condition key1
		;hl = labelnumber
if a=false	;if false jump then reverse
 ld a,c
 call reverse
 ld c,a		;restore value
endif
if c in [overflow,nooverflow]
 if b = retaus
  if c = overflow
   ld ix,auszeile
   call prttab
   prtstr 'JR Z,'
   call newlabel	;loose old label
   call putlabel
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'RET NC'
   call putline
   ld ix,auszeile
   call putlabel	;jump there
   call lblsgn
   call putline
  else
   ld ix,auszeile
   call prttab
   prtstr 'RET Z'
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'RET C'
   call putline
  endif
 else { normal jumps }
  if c = overflow
   ld ix,auszeile
   call prttab
   prtstr 'JR Z,'
   push hl		;save jump to label
   call newlabel	;gen new one
   call putlabel
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'JP NC,'
   ex (sp),hl		;get old one
   call putlabel
   call putline
   pop hl		;get new label
   ld ix,auszeile
   call putlabel
   call lblsgn
   call putline		;jump there
  else
   ld ix,auszeile
   call prttab
   prtstr 'JP Z,'
   call putlabel
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'JP C,'
   call putlabel
   call putline
  endif
 endif
else
 if b = retaus
  if c = nocond
   ld ix,auszeile
   call prttab
   ld iy,sym2
   ld a,retaus
   call prtind
   call putline
  else
   ld ix,auszeile
   call prttab
   ld iy,sym2
   ld a,retaus
   call prtind
   ld a,c	;key1 as index
   ld iy,key1	;
   call prtind
   call putline
  endif
 else
  if c = nocond
   ld ix,auszeile
   call prttab
   ld iy,sym2
   ld a,b	;type of jump
   call prtind
   call putlabel	;hl is nr
   call putline
  else
   ld ix,auszeile
   call prttab
   ld iy,sym2
   ld a,b
   call prtind
   ld iy,key1	;cond
   ld a,c
   call prtind
   ld (ix+0),','
   inc ix
   call putlabel
   call putline
  endif
 endif
endif
ret
		
; code generator
gencond::		;a=true,false
			;b=jump type main
			;hl = label
			;de = pointer to source


call genexpr
ret


; parser for syntax check and preview
; only de is valid, pointer to next symbol
; afterwards points to next symbol not in syntax
; REST DESTROYED
parseexpr::
 call parseterm
 ld ix,key3	;and or in check
 push de	;save adress if not odersymbol
 call getkey
 while a = odersym
  call parseterm
  pop bc	;remove old de
  push de	;save new de
  ld ix,key3
  call getkey
 endwhile  
 pop de		;not odersym
ret

parseterm::
 call parsefaktor
 ld ix,key3
 push de	;save old one
 call getkey
 while a = undsym
  call parsefaktor
  pop bc	;can be removed
  push de	;new one
  ld ix,key3
  call getkey
 endwhile
 pop de		;get valid one
ret

parsefaktor::
 push de
 ld ix,key3
 call getkey
 if a = notsym
  pop bc	;throw away
  call parsefaktor
  exit		;with new de
 endif
 pop de
 call igbn
 ld a,(de)
 if a = '['
  inc de
  call parseexpr
  call igbn
  ld a,(de)
  if a = ']'
   inc de
   exit		;ok s.o.
  endif
  exit		;SYNTAX ERROR
 endif
 ; de valid points to first symbol
 call scanass	;must be assembly
 ;
 push de	;can be in or comparison
 ld ix,sym3
 call getsym	;scan for symbol
 if a = nocomp	;must be in
  pop de	;get old pointer
  push de
  ld ix,key3	;scan for in
  call getkey
  if a = insym
   pop bc	;de is valid
   call igbn	;check [ .. ]
   ld a,(de)
   if a = '['
    inc de	;to next
    loop
     call scanass	;first is assembly
     exitif b = syntax	;syntaxfehler ist terminator
     call igbn
     ld a,(de)
     if a = ','
      inc de
     else
      if a = '.'
       inc de
       ld a,(de)
       if a = '.'
        inc de
       endif
      endif
     endif
     call igbn
     ld a,(de)		;next symbol
     exitif a=']' or a = 0
    endloop
    if a = ']'
     inc de		;ok to next symbol
    endif
   else
    nop		;SYNTAX ERROR
   endif
  else
   pop de	;old pointer SYNTAX ERROR
  endif		
 else		;is condition
  pop bc	;de is ok
  call scanass	;to end
 endif
ret



genexpr::
		;b = jmptype
		;de = pointer
		;hl = label
push af
push bc
push de		;start pointer
push hl
call parseterm	;get de to nextsymbol
ld ix,key3
call getkey
if a = odersym
 pop hl			;label
 pop de 
 pop bc			;b=jmptyp
 pop af			;generate code for first op
 if a = true		;true at or
  repeat
   push hl
   push bc		;main parameter   
   ld a,true
   call genterm		;de must be valid afterwards
   push de		;save
   ld ix,key3
   call getkey
   if a = odersym		;a remains
    pop bc		;discard
   else
    pop de		;else get old one
   endif
   pop bc
   pop hl		;main parameter
  until a <> odersym
 else			;false at or
  push hl		;save old label
  call newlabel		;get a new one
  loop
   push hl
   push de
   push bc
   call parseterm	;search next symbol
   ld ix,key3
   call getkey		;test if and symbol
   pop bc
   pop de
   pop hl
   exitif a <> odersym
   push hl
   push bc
   ld a,true
   ld b,jpaus		;must be jump
   call genterm		;generate term
   ld ix,key3
   call getkey		;must be ok
   if a <> odersym
    error 'SYSTEM ERROR IN EXPR'
   endif
   pop bc
   pop hl
  endloop
  ex (sp),hl		;exchange labels
  ld a,false		;hl,de,b valid
  call genterm
  pop hl		;get old label
  ld ix,auszeile
  call putlabel
  call lblsgn
  call putline
 endif
else
 pop hl
 pop de
 pop bc
 pop af
 call genterm
endif
ret

genterm::	;a = flag
		;b = jmptype
		;de = pointer
		;hl = label
push af
push bc
push de		;start pointer
push hl
call parsefaktor	;get de to nextsymbol
ld ix,key3
call getkey
if a = undsym
 pop hl			;label
 pop de 
 pop bc			;b=jmptyp
 pop af			;generate code for first op
 if a = false		;false at and
  repeat
   push hl
   push bc		;main parameter   
   ld a,false
   call genfaktor	;de must be valid afterwards
   push de		;save
   ld ix,key3
   call getkey
   if a = undsym	;a remains
    pop bc		;discard
   else
    pop de		;else get old one
   endif
   pop bc
   pop hl		;main parameter
  until a <> undsym
 else			;true at and
  push hl		;save old label
  call newlabel		;get a new one
  loop
   push hl
   push de
   push bc
   call parsefaktor	;search next symbol
   ld ix,key3
   call getkey		;test if or symbol
   pop bc
   pop de
   pop hl
   exitif a <> undsym
   push hl
   push bc
   ld a,false
   ld b,jpaus		;must be jump
   call genfaktor	;generate faktor
   ld ix,key3
   call getkey		;must be ok
   if a <> undsym
    error 'SYSTEM ERROR IN TERM'
   endif
   pop bc
   pop hl
  endloop
  ex (sp),hl		;exchange labels
  ld a,true		;hl,de,b valid
  call genfaktor
  pop hl		;get old label
  ld ix,auszeile
  call putlabel
  call lblsgn
  call putline
 endif
else
 pop hl
 pop de
 pop bc
 pop af
 call genfaktor
endif
ret

genfaktor::		;a=tf true,false
			;b=jump type 
			;de=start of text
			;hl=labelnr

push af
push bc
call igbn		;ignore blanks
pop bc			;new de
pop af			;de,hl still valid
;
push af
push bc			;now test for not symbol
push de			;save start
ld ix,key3		;scan for not
call getkey
if a=notsym
 pop bc			;remove old de
 pop bc
 pop af			;true flag
 if a=true
  ld a,false
 else
  ld a,true
 endif
 call genfaktor		;RECURSIVE CALL NOT NOT NOT ...
 exit			;leave procedure genfaktor
else
 pop de			;get old pointer
 pop bc
 pop af
endif
;
;
push af
push bc
push de			;save for [ test
call igbn
ld a,(de)
if a = '['
 inc de			;point to next symbol
 pop bc			;throw away
 pop bc
 pop af			;all must be valid
 call genexpr		;RECURSIVE CALL
 call igbn		;test ]
 ld a,(de)
 if a = ']'
  inc de
  exit			;FINAL OK s.o POINT TO NEXT
 else
  error 'ERROR  ] MISSING'
  exit
 endif
else
 pop de
 pop bc
 pop af
endif

;
; test whether in, condition or single 
; kontextsensive part
push af			;save flag
push bc			;save jumptype
push de			;start pointer
call scanass		;now try to get symbol afterwards
			;de points there
push de			;save second
ld ix,sym3
call getsym		;scan symbol no terminator
			;now akku valid
if a=nocomp
 ;no comparision
 ;check whether IN symbol is there
 pop de			;get prev one
 ld ix,key3
 call getkey		;normal keyword
 if a=insym
  pop de
  pop bc
  pop af		;old one values
  call genin		;generate code for in
 else
  ; must be single consition
  pop de		;pointer to start
  ld ix,key1		;condition key
  call getkey		;akku is keyword
  if a=nocond
   error 'ERROR WRONG EXPRESSION'
   pop bc
   pop af		;clean stack
  else
   pop bc
   ld c,a		;b=type c=cond
   pop af		;a=true,false
   call gencode		;de,hl valid
  endif
 endif
else
 ;must be comparision
 pop de		;throw away
 pop de
 pop bc 
 pop af	;start analyse
 call genvergleich
endif
ret


genin::			; nn in [   ]
			; de -> start
ld (gentrue),a		; flag old
ld a,b
ld (genjmp),a
ld (gen1labl),hl	;save all parameters
; de points to start
ld (genw),de		;save start of de
call scanass		;c=count b=code
;
if b <> areg		;must load register
 push de		;c=count
 push bc
 ld ix,auszeile
 call prttab
 prtstr 'LD A,'
 pop bc
 ld hl,(genw)		;start of text
 call prtchl
 call putline
 pop de
endif
; de points to IN
ld ix,key3
call getkey
if a <> insym
 error 'ERROR   SYNTAX'
 exit
endif
; de points to rest of string
call igbn
; symbol must be [
ld a,(gentrue)
if a = false
 call newlabel	;get new label
 push hl
 ld hl,(gen1labl)
 ld (gen2labl),hl
 pop hl
 ld (gen1labl),hl	;is temp label
endif
ld a,(de)
if a='['
 inc de			;next symbol
 ld a,false
 ld (final),a		;flag for final exec
 repeat			;de must be valid
  ld (op1w),de
  call scanass		;scan inputline
  ld a,c
  ld (op1len),a		;save length of first op
  if b <> syntax
   call igbn
   ld a,(de)		;terminator
   if a in [2ch,5dh]	; ',' ']'
    if a=5dh
     ld a,true		;last expression
     ld (final),a
    endif
    inc de		;point to next 
    push de		;save pointer
    ld a,(gentrue)	;check if true
    if a=true
     ; must use genjmp  
     ld ix,auszeile
     call prttab
     prtstr 'CP '
     ld hl,(op1w)
     ld a,(op1len)
     ld c,a
     call prtchl
     call putline	;now generate jump
     ld hl,(gen1labl)
     ld a,(genjmp)
     ld b,a
     ld a,zero
     ld c,a
     ld a,true		;true jump 
     call gencode
    else
     ld ix,auszeile
     call prttab
     prtstr 'CP '
     ld hl,(op1w)
     ld a,(op1len)
     ld c,a
     call prtchl
     call putline
     ld ix,auszeile
     call prttab
     prtstr 'JP Z,'
     ld hl,(gen1labl)
     call putlabel
     call putline
    endif
    pop de		;get old pointer
   else
    if a=2eh		; '.'
     inc de		;next must be dot
     ld a,(de)
     if a=2eh		;then ok
      inc de		;to next char
      call igbn
      ld (op2w),de	;save pointer second operand
      call scanass	;get next de
      ld a,c
      ld (op2len),a
      if b <> syntax
       call igbn
       ld a,(de)
       if a in [2ch,5dh]
        if a = 5dh
         ld a,true
         ld (final),a
        endif       
        inc de		;point to next symbol
        push de		;save pointer
        ld a,(gentrue)
        if a = true
         ; generate direct code
         ; use temp label for skip
         ld ix,auszeile
         call prttab
         prtstr 'CP '
         ld hl,(op2w)
         ld a,(op2len)
         ld c,a
         call prtchl
         prtstr '+1'
         call putline
         call newlabel	;save label         
         push hl
         ld ix,auszeile
         call prttab
         prtstr 'JR NC,'
         call putlabel
         call putline
         ld ix,auszeile
         call prttab
         prtstr 'CP '
         ld hl,(op1w)
         ld a,(op1len)
         ld c,a
         call prtchl
         prtstr '+0'	;savety
         call putline
         ld hl,(gen1labl)
         ld a,(genjmp)
         ld b,a
         ld c,nocarry
         ld a,true
         call gencode
         pop hl		;get old label VALID
         ld ix,auszeile
         call putlabel
         call lblsgn
         call putline
        else
         ; false generate
         ld ix,auszeile
         call prttab
         prtstr 'CP '
         ld hl,(op2w)
         ld a,(op2len)
         ld c,a
         call prtchl
         prtstr '+1'
         call putline
         call newlabel	;skip label
         push hl
         ld ix,auszeile
         call prttab
         prtstr 'JR NC,'
         call putlabel
         call putline
         ld ix,auszeile
         call prttab
         prtstr 'CP '
         ld hl,(op1w)
         ld a,(op1len)
         ld c,a
         call prtchl
         prtstr '+0'
         call putline
         ld ix,auszeile
         call prttab
         prtstr 'JP NC,'
         ld hl,(gen1labl)
         call putlabel
         call putline
         pop hl		;get old label
         ld ix,auszeile
         call putlabel
         call lblsgn
         call putline
        endif
        pop de		;restore old pointer
       else		;error in terminator
        error 'ERROR IN TERMINATOR'
        ld a,true
        ld (final),a
       endif
      else
       ld a,true
       ld (final),a
       error 'ERROR IN PARAMETER'
      endif
     else
      ld a,true
      ld (final),a
      error 'ERROR IN PARAMETER'
     endif
    else
     ld a,true
     ld (final),a
     error 'ERROR IN PARAMETER'
    endif
   endif
  else
   error 'ERROR  IN PARAMETER'
   ld a,true
   ld (final),a
  endif
  ld a,(final)
 until a=true		;until end encountered
 ld a,(gentrue)
 if a = false
  ld hl,(gen2labl)	;skip to this label
  ld a,(genjmp)
  ld b,a
  ld c,nocond		;unconditional
  ld a,true
  call gencode		;ret,or jumps
  ld ix,auszeile
  ld hl,(gen1labl)
  call putlabel
  call lblsgn
  call putline
 endif
else
 error 'ERROR MISSING ['
endif
ret


genvergleich::
ld (optrue),a	;save it  nonrecursive
ld a,b
ld (opjmp),a	;save jump type
ld (oplabl),hl	;jump to label
		;de points to start of text
; seperate operands
ld (op1w),de	;first operand
call scanass	;get length
ld a,c		;length
ld (op1len),a	;
ld a,b
ld (op1reg),a	;register type first operand
; get keyword middle
ld ix,sym3
call getsym	;scan symbol condition
		;de points to next start
ld (opvgl),a	;save comparison
ld (op2w),de
call scanass	;get length and type
ld a,c
ld (op2len),a
ld a,b
ld (op2reg),a	;type of operand
;
; de is valid NOW
; now test cases for comparison
ld a,(opvgl)
if a in [notequal,equal]
 if a = equal
  ld a,zero
 else
  ld a,nonzero
 endif
 ld (opid1),a	;jump type
 ld a,(op1reg)	;test first operand
 if a = areg
  ld a,(op2reg)
  if a = null
   ld ix,auszeile   
   call prttab
   prtstr 'OR A'
   call putline
  else 
   ld ix,auszeile
   call prttab
   prtstr 'CP '
   ld hl,(op2w)
   ld a,(op2len)
   ld c,a
   call prtchl
   call putline
  endif
 else
  ld a,(op2reg)
  if a = areg	;second operand is akku
   ld a,(op1reg)
   if a = null
    ld ix,auszeile
    call prttab
    prtstr 'OR A'
    call putline
   else
    ld ix,auszeile
    call prttab
    prtstr 'CP '
    ld hl,(op1w)
    ld a,(op1len)
    ld c,a
    call prtchl
    call putline
   endif
  else		;both are not akku
   ld a,(op1reg)
   if a = null
    ld ix,auszeile
    call prttab
    prtstr 'XOR A'
    call putline
   else
    ld ix,auszeile
    call prttab
    prtstr 'LD A,'
    ld hl,(op1w)
    ld a,(op1len)
    ld c,a
    call prtchl
    call putline
   endif
   ld a,(op2reg)
   if a = null
    ld ix,auszeile
    call prttab
    prtstr 'OR A'
    call putline
   else
    ld ix,auszeile
    call prttab
    prtstr 'CP '
    ld hl,(op2w)
    ld a,(op2len)
    ld c,a
    call prtchl
    call putline
   endif
  endif
 endif
else
 ; spezial < > >= <=
 ld a,(opvgl)
 if a = greater
  push de		;save de 
  ld a,(op1len)
  ld c,a
  ld a,(op2len)
  ld (op1len),a
  ld a,c
  ld (op2len),a	;exchange operands
  ld a,(op1reg)
  ld c,a
  ld a,(op2reg)
  ld (op1reg),a
  ld a,c
  ld (op2reg),a
  ld hl,(op1w)
  ld de,(op2w)
  ld (op1w),de
  ld (op2w),hl
  ld a,less
  ld (opvgl),a
  pop de
 endif
 ld a,(opvgl)
 if a = lessequal
  push de	;save de
  ld a,(op1len)
  ld c,a
  ld a,(op2len)
  ld (op1len),a
  ld a,c
  ld (op2len),a	;exchange operands
  ld a,(op1reg)
  ld c,a
  ld a,(op2reg)
  ld (op1reg),a
  ld a,c
  ld (op2reg),a
  ld hl,(op1w)
  ld de,(op2w)
  ld (op1w),de
  ld (op2w),hl
  ld a,greatequal
  ld (opvgl),a
  pop de
 endif
 ld a,carry 
 ld (opid1),a	;carry is condition default
 ld a,(opvgl)
 if a = greatequal
  ld a,nocarry
  ld (opid1),a
 endif
 ld a,(op1reg)
 if a = areg
  ; a operand reg
  ld ix,auszeile
  call prttab
  prtstr 'CP '
  ld hl,(op2w)
  ld a,(op2len)
  ld c,a
  call prtchl
  call putline
 else
  ld a,(op2reg)
  if a = areg
   ; reg operand a
   ; spezial case   nnn < A or nnn >= A
   ld a,overflow
   ld (opid1),a
   ld a,(opvgl)
   if a = greatequal
    ld a,nooverflow
    ld (opid1),a
   endif
   ld ix,auszeile
   call prttab
   prtstr 'CP '
   ld hl,(op1w)
   ld a,(op1len)
   ld c,a
   call prtchl
   call putline
  else
   ; nnn oper  mmm
   ld ix,auszeile
   call prttab
   prtstr 'LD A,'
   ld hl,(op1w)
   ld a,(op1len)
   ld c,a
   call prtchl
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'CP '
   ld hl,(op2w)
   ld a,(op2len)
   ld c,a
   call prtchl
   call putline
  endif
 endif
endif
;
ld a,(opjmp)
ld b,a
ld a,(opid1)
ld c,a
ld hl,(oplabl)
ld a,(optrue)
call gencode	;generate jump
ret
;

;
getscan::		;fetch an input line
			;de points to terminalsymbol
			;a is the symbol from table KEY
 call getline		;fetch line
 call sepline		;divide it
 ld de,sourcelin	;analyse it
 ld ix,key		;key table
 call getkey		;result akku,de
ret
;

txterra::
defm 'AT LINE '
defb 0

crlf: defb 0dh,0ah,0

errein::
 push bc
 push de
 push ix
 push iy
 push hl
 call print	;output error name
 ld hl,crlf
 call print	;to console
 ld hl,txterra
 call print
 ld hl,(inline)
 call dezout
 ld hl,crlf
 call print
 pop iy
 ld ix,auszeile	;also to disk
 call prt1str
 call putline
 ld hl,(err)
 inc hl
 ld (err),hl
 pop iy
 pop ix
 pop de
 pop bc
ret

;


statement::		;recursive analyser
			;de - > line	
			;akku is key symbol

ld hl,(level)
inc hl
ld (level),hl		;level of recursion
push af
push de
if a <> assembly
 call gencomment	;build comment and labels
endif
pop de
pop af

ld hl,tabcase		;simulate a case
ld c,a
ld b,0
add hl,bc
add hl,bc		;index * 2 + base
ld c,(hl)		;lsb
inc hl
ld b,(hl)		;msb
ld hl,backstate
push hl			;return adresse
push bc
pop hl
jp (hl)			;and execute it
;
backstate::		;jump there back
ld hl,(level)
dec hl
ld (level),hl		;level of recursion
ret


tabcase::		;must be same order as in keyfield
defw genif		;if
defw errifelse		;elseif
defw errelse		;else
defw errendif		;endif
defw genrepeat		;repeat
defw erruntil		;until
defw genwhile		;while
defw errendwhile	;endwhile
defw genloop		;loop
defw errendloop		;endloop
defw genexitif		;exitif
defw exexit		;exit
defw gendo		;do
defw errenddo		;enddo
defw assem		;assembly DEFAULT


genif::			;generate if instr de->pointer
call igbn		;ignore leading blanks
call newlabel		;hl = label
ld a,false		;tf = false
ld b,jpaus		;with jump absolute
push hl			;save it for future use
call gencond		;GENERATE CODE de->startsymbol
;
call getscan
ld b,a
ld a,(eof)
while a<>1 and b<>endifsymbol and b<>elsesymbol and b<>elseifsymbol
 ld a,b
 call statement
 call getscan
 ld b,a
 ld a,(eof)
endwhile

push bc
call gencomment
pop bc

if b=elseifsymbol	;case of elseif
 call newlabel	;global destination
 push hl	;save on stack <> 0
 repeat
  pop hl	;get global
  push hl
  ld ix,auszeile
  call prttab
  prtstr 'JP '
  call putlabel
  call putline
  pop hl
  ex (sp),hl	;get lokal temp exchange
  ld ix,auszeile
  call putlabel
  call lblsgn
  call putline	;mark as label
  call newlabel	;and new jump replaces old
  push hl
  ld a,false	;hl valid
  ld b,jpaus
  call gencond	;gen code
  pop hl	;new
  ex (sp),hl	;to stack
  push hl	;global label
  call getscan
  ld b,a
  ld a,(eof)
  while a<>1 and b<>endifsymbol and b<>elseifsymbol and b<>elsesymbol
   ld a,b
   call statement
   call getscan
   ld b,a
   ld a,(eof)
  endwhile
  push bc
  call gencomment
  pop bc
 until b<>elseifsymbol
 ; two stack frames reserved
 ; to global dest
 ; so exchange global stack
 pop hl
 ex (sp),hl
 push hl	;first lokal then global
else
 ld hl,0	;mark no label
 ex (sp),hl
 push hl	;save old one
endif


if b=elsesymbol
 call newlabel	;new label to hl
 ld ix,auszeile
 call prttab
 prtstr 'JP '
 call putlabel
 call putline
 ex (sp),hl	;get old label and exchange
 ld ix,auszeile
 call putlabel
 call lblsgn
 call putline	;mark as label
 call getscan
 ld b,a
 ld a,(eof)
 while a<>1 and b<>endifsymbol
  ld a,b
  call statement
  call getscan
  ld b,a
  ld a,(eof)
 endwhile
 call gencomment
endif
pop hl		;get old label
ld ix,auszeile
call putlabel
call lblsgn
call putline
pop hl
ld a,h
or l
exitif z	;no more labels
ld ix,auszeile
call putlabel
call lblsgn
call putline	;else elseif was there
ret

genrepeat::	;
call newlabel
push hl		;save it for until
ld ix,auszeile
call putlabel
call lblsgn
call putline
call getscan
ld b,a
ld a,(eof)
while a<>1 and b<>untilsymbol
 ld a,b
 call statement
 call getscan
 ld b,a		;de is valid
 ld a,(eof)
endwhile
; de is valid points to next symbol
push de
call gencomment
pop de
ld a,false
ld b,jpaus	;
pop hl		;to label
call gencond
ret
;

genwhile::	;de points to next symbol
call newlabel	;hl is new label
push hl		;save this label
push de		;save pointer
ld ix,auszeile
call putlabel
call lblsgn
call putline
pop de
call newlabel	;2cond label
push hl		;save also this one
ld a,false
ld b,jpaus	;hl,de valid
call gencond
call getscan
ld b,a
ld a,(eof)
while a<>1 and b <> endwhilesymbol
 ld b,a
 call statement
 call getscan
 ld b,a
 ld a,(eof)
endwhile
call gencomment	;ok
pop hl		;last one
ex (sp),hl	;but need other one
ld ix,auszeile
call prttab
prtstr 'JP '
call putlabel
call putline
pop hl		;final label
ld ix,auszeile
call putlabel
call lblsgn
call putline
ret



genexitif::	;de points to symbol
 ld a,true	;gen true jump
 ld b,retaus	;with return
 ld hl,0	;hl undefined no label
 call gencond
ret



genloop::		; loop executive
 call newlabel		;hl is new label
 ld ix,auszeile
 call prttab
 prtstr 'PUSH HL'
 call putline
 ld ix,auszeile
 call prttab
 prtstr 'LD HL,'
 call putlabel
 call putline
 ld ix,auszeile
 call prttab
 prtstr 'EX (SP),HL'
 call putline
 push hl		;save jump over label
 call newlabel		;next label 
 ld ix,auszeile
 call putlabel
 call lblsgn
 call putline
 push hl		;save label because recursive
 call getscan		;akku new defined
 ld b,a			;save it temp
 ld a,(eof)		;control it
 while a<>1 and b<>endloopsymbol
  ld a,b		;de points to line
  call statement	;recursive call
  call getscan
  ld b,a
  ld a,(eof)		;test end also
 endwhile
 call gencomment	;label comment output
 pop hl			;back jumps label
 ld ix,auszeile
 call prttab
 prtstr 'JP '
 call putlabel
 call putline
 pop hl			;skip label
 ld ix,auszeile
 call putlabel
 call lblsgn
 call putline
ret

gendo::			;generate do operator
			;de points to nextsymbol
call igbn		;to first valid symbol
push de			;save start  
call scanass		;de to nextsymbol
			;c=count b=symbol
if not b in [bcreg..lreg]
 error 'ERROR WRONG DO PARAMETER'
 pop de			;clean stack
 exit
endif
push bc			;save count and symbol
call igbn
ld a,(de)
if a = ','		;load first parameter
 ld ix,auszeile
 call prttab
 prtstr 'LD '
 pop bc
 pop hl
 push hl
 push bc		;hl -> start
 ld c,255		;print till end
 call prtchl
 call putline
endif
pop bc
pop de			;pointer to start of string
;
push bc			;save only symbolname
;
call newlabel		;hl is new label
ld ix,auszeile
call putlabel
call lblsgn
call putline		;hl strill valid
;
push hl			;save labelnumber
;
call getscan
ld b,a
ld a,(eof)
while a <> 1 and b <> enddosymbol
 ld a,b
 call statement
 call getscan
 ld b,a
 ld a,(eof)
endwhile
;
call gencomment
;
pop hl		;label
pop bc		;b=symbolname of register
;
push hl		;save label
push bc
ld ix,auszeile
call prttab
prtstr 'DEC '
pop bc
push bc
if b in [bcreg..lreg]
 ld iy,key2
 ld a,b		;index
 call prtind
endif
call putline
pop bc
if b in [bcreg..hlreg]
 if b = bcreg
  ld ix,auszeile
  call prttab
  prtstr 'LD A,B'
  call putline
  ld ix,auszeile
  call prttab
  prtstr 'OR C'
  call putline
 else
  if b = dereg
   ld ix,auszeile
   call prttab
   prtstr 'LD A,D'
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'OR E'
   call putline
  else
   if b = hlreg
    ld ix,auszeile
    call prttab
    prtstr 'LD A,H' 
    call putline
    ld ix,auszeile
    call prttab
    prtstr 'OR L'
    call putline
   endif
  endif
 endif
else
 if b = ixreg
  ld ix,auszeile
  call prttab
  prtstr 'DEFB 0DDH'
  call putline
  ld ix,auszeile
  call prttab
  prtstr 'LD A,H'
  call putline
  ld ix,auszeile
  call prttab
  prtstr 'DEFB 0DDH'
  call putline
  ld ix,auszeile
  call prttab
  prtstr 'OR L'
  call putline
 else
  if b = iyreg
   ld ix,auszeile
   call prttab 
   prtstr 'DEFB 0FDH'
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'LD A,H'
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'DEFB 0FDH'
   call putline
   ld ix,auszeile
   call prttab
   prtstr 'OR L'
   call putline
  else
   if b = spreg
    error 'ERROR SP is dangerous'
   endif
  endif
 endif
endif
pop hl
ld ix,auszeile
call prttab
prtstr 'JP NZ,'
call putlabel
call putline
ret






exexit::
 ld ix,auszeile
 call prttab
 prtstr 'RET'
 call putline
ret


; error subroutines

errifelse::
 error 'ERROR ELSEIF WITHOUT IF'
ret

errelse::
 error 'ERROR ELSE WITHOUT IF'
ret
 

errendif::
 error 'ERROR ENDIF WITHOUT IF'
ret

erruntil::
 error 'ERROR UNTIL WITHOUT REPEAT'
ret

errendwhile::
 error 'ERROR ENDWHILE WITHOUT WHILE'
ret


errendloop::
 error 'ENDLOOP WITHOUT LOOP'
ret



errenddo::
 error 'ENDDO WITHOUT DO'
ret


; default subroutine

assem::			;std output assembly statement
 call toaus		;includes putline
ret


; MAIN PROGRAMM
;
start::		;Hauptprogramm start
ld hl,(bdos+1)	;get stack frame
ld sp,hl	;set to max
ld a,0		;default is console
ld (iodest),a
ld (iosrc),a
ld (eof),a	;no eof
ld (tabcnt),a	;tab counter
ld hl,0
ld (labelnr),hl	;start with label 0
ld (level),hl

ld hl,txt1
call print
;
; init default tables
; 
ld hl,fcb1
ld de,fcbread
ld bc,36
ldir
ld hl,fcb2
ld de,fcbwrite
ld bc,36
ldir
;
ld a,0
ld (comsw),a	;comments
; determine if console or disk
ld a,(80h)	;get buffer
if a<>0
 ld b,a		;counter 1..n CHARS
 ld hl,80h+1	;first char
 while b<>0 and (hl)=' '
  inc hl
  dec b 
 endwhile	;ignore leading blanks  
 if (hl) <> '/'
  push hl
  push bc
  ld hl,5ch+1
  ld de,fcbread+1
  ld bc,8
  ldir
  ld hl,5ch+1
  ld de,fcbwrite+1
  ld bc,8
  ldir
  ld a,1
  ld (iosrc),a
  ld (iodest),a	;destination and source
  pop bc
  pop hl  
 endif
 while b<>0 and (hl)<>'/'
  inc hl
  dec b
 endwhile
 if (hl) = '/'
  inc hl
  dec b
  while b <> 0
   if (hl) = 'C'
    ld a,1
    ld (comsw),a	;no comments
   else
    if (hl) = 'L'
     ld a,0
     ld (iodest),a
    else
     if (hl) = 'P'
      ld a,2
      ld (iodest),a	;to printer
     endif
    endif       
   endif
   inc hl
   dec b
  endwhile
 endif 
endif		;no switches all from console
;
ld a,(iosrc)
if a<>0
 call initflop
else
 ld hl,txtaa
 call print
endif
;
;
mainlp::	;mark for test
;
repeat
 call getscan	;de->terminalsymb 
 call statement	;
 ld a,(eof)
until a=1

ld hl,txt2
call print

ld hl,(inline)
call dezout
ld hl,txt3
call print
ld hl,(outline)
call dezout
ld hl,txt4
call print
ld hl,(err)
call dezout
ld hl,txt5
call print
;
ld a,(iodest)
if a<>0
 call terminate	;close files
endif
;
call 0		;warm boot end of compilation




; tables and constant data


fcb1::		;default table
defb 0
defb 20h,20h,20h,20h,20h,20h,20h,20h
defm 'STR'
defb 0,0,0,0
defb 0,0,0,0,0,0,0,0
defb 0,0,0,0,0,0,0,0
defb 0,0,0,0

fcb2::		;default table
defb 0
defb 20h,20h,20h,20h,20h,20h,20h,20h
defm 'MAC'
defb 0,0,0,0
defb 0,0,0,0,0,0,0,0
defb 0,0,0,0,0,0,0,0
defb 0,0,0,0







txt1::
defb 0dh,0ah
defm '------------------------------'
defb 0dh,0ah
defm 'Strukta   Compiler Version 1.4'
defb 0dh,0ah
defm 'by Rolf-Dieter Klein  (C) 1983 '
defb 0dh,0ah
defm 'Munic             West Germany'
defb 0dh,0ah
defm 'Last change           8.1.1983'
defb 0dh,0ah
defm '------------------------------'
defb 0dh,0ah,0


txt2::
defb 0dh,0ah,0
;
txt3:
defm ' line(s) were read'
defb 0dh,0ah,0
txt4:
defm ' line(s) were generated'
defb 0dh,0ah,0
txt5:
defm ' error(s) were detected'
defb 0dh,0ah
defm ' End of Complilation '
defb 0dh,0ah,0
;

txtaa::
defb 0dh,0ah
defm 'Please enter Struktalines End = CTRL Z '
defb 0dh,0ah,0

key::		;keyword field a
defm 'IF'
defb 0
defm 'ELSEIF'	;must be before else
defb 0
defm 'ELSE'
defb 0
defm 'ENDIF'
defb 0
defm 'REPEAT'
defb 0
defm 'UNTIL'
defb 0
defm 'WHILE'
defb 0
defm 'ENDWHILE'
defb 0
defm 'LOOP'
defb 0
defm 'ENDLOOP'
defb 0
defm 'EXITIF'
defb 0
defm 'EXIT'
defb 0
defm 'DO'
defb 0
defm 'ENDDO'
defb 0
defb 0,0	;end of table

;
key1::		;table of conditions
defm 'Z'
defb 0
defm 'C'
defb 0
defm 'PE'
defb 0
defm 'P'
defb 0
defm 'OV'
defb 0
defm 'NV'
defb 0
defm 'M'
defb 0
defm 'PO'
defb 0
defm 'NC'
defb 0
defm 'NZ'
defb 0
defb 0,0
;
;
key2:
defm 'BC'
defb 0
defm 'DE'
defb 0
defm 'HL'
defb 0
defm 'SP'
defb 0
defm 'IX'
defb 0
defm 'IY'
defb 0
defm 'A'
defb 0
defm 'B'
defb 0
defm 'C'
defb 0
defm 'D'
defb 0
defm 'E'
defb 0
defm 'H'
defb 0
defm 'L'
defb 0
defb 0,0

;
key3::
defm 'OR'
defb 0
defm 'AND'
defb 0
defm 'NOT'
defb 0
defm 'IN'
defb 0
defb 0,0


;
sym2::		;for output only
defm 'JP '
defb 0
defm 'JR '
defb 0
defm 'RET '
defb 0
defm 'CALL '
defb 0
defb 0,0

sym3:
defm '<>'
defb 0
defm '<='
defb 0
defm '>='
defb 0
defm '='
defb 0
defm '<'
defb 0
defm '>'
defb 0
defb 0,0





; Ram Teil
iodest:: defb 0	;destination 0=console 1=disk
iosrc::  defb 0 ;source 0=console 1=disk
;
eof:: defb 0	;end of file
;
inline:: defw 0	;count of input lines
outline:: defw 0 ;count of output lines
err::	defw 0 ;count of errors
;
; temp sto
desto:: defw 0	;for getkey
de1sto:: defw 0	;getkey
bcsto::	defw 0
bc1sto:: defw 0
;
flagp:: defb 0	;in putline
flag:: defb 0	;in scanass
;
state::	defb 0	;state in sepline

tabcnt:: defb 0 ; tab counter
;
labelnr:: defw 0 ; fuer labelgenerator GLOBAL
level:: defw 0	;level of recursion
;

; lokale variable fuer genvergleich
; also used by genin because
; they are exclusive called and
; not recursive
op1w:: defw 0	;pointer to first operand
op1len:: defb 0	;length of first operand
op1reg:: defb 0
op2w:: defw 0
op2len:: defb 0
op2reg:: defb 0
opvgl::	defb 0	;value of conditioncode
opjmp:: defb 0	;stores value of jmptype
optrue:: defb 0	;stores true,false
oplabl:: defw 0	;stores label of jump
opid1:: defb 0	;type of condition
;
;
; lokale variable for genin
genjmp:: defb 0
gentrue:: defb 0
gen1labl:: defw 0
gen2labl:: defw 0
genid1:: defb 0
genw:: defw 0
final:: defb 0
;

labelx:: defw 0	;pointer to einzeile
lenlab:: defb 0	;length
instr::  defw 0 ;pointer to einzeile
lenins:: defb 0
comment:: defw 0 ;pointer to einzeile
lencom:: defb 0 ;comment length
;
comsw:: defb 0	;0=comments 1=nocomments
;
;
einzeile:: defs 256 ;input line buffer 0=terminator
auszeile:: defs 256 ;output line buffer 0=terminator
;
sourcelin:: defs 256 ; line for instr part to be analysed


;
fcbread:: defs 36
fcbwrite:: defs 36

rbuflen:: defw 0
wbuflen:: defw 0


freram::


rbuf equ $
wbuf equ rbuf + 4096
next equ wbuf + 4096
;
global wbuf,rbuf	;for test only

end start