MODULE ; ST.ACT

; Symbol table lister for ACTION!
; compiler.  Lists local variables
; per PROC/FUNC and globals at end
; of compilation.

; copyright 1983
; by Action Computer Services
; All Rights Reserved

; version 1.0
; last modified November 6, 1983

; user options:
;
; change Open call in SPLEnd to get
; listing to go to disk


DEFINE STRING = "CHAR ARRAY"
DEFINE JMP = "$4C" ; JMP addr16

TYPE INSTR=[BYTE op CARD addr]
INSTR Segvec=$4C6, DCLvec=$4D4
INSTR SPLvec=$4DD

TYPE ENTRY =
[
; STRING name(?)
  BYTE vtype
  CARD adr
  BYTE numargs
; BYTE ARRAY argTypes(8)
]

BYTE oldDevice, curBank=$4C9
BYTE pf, Zop=$8A, tZop
CARD curproc=$8E
ENTRY POINTER e
CHAR ARRAY cmdLine(0)=$590
BYTE ARRAY bank(0)=$D500
BYTE ARRAY zpage(32), temps(16)


PROC PrintH(CARD v)
  PrintF("%H", v)
RETURN


PROC BaseType(BYTE et)
  et = et & $7

  IF     et=1 THEN Print("CHAR")
  ELSEIF et=2 THEN Print("BYTE")
  ELSEIF et=3 THEN Print("INT")
  ELSEIF et=4 THEN Print("CARD")
  FI
RETURN


BYTE FUNC GetType(BYTE et)
  CHAR ch
  BYTE pfFlag, t, oldT
  ENTRY POINTER next
  STRING name

  pfFlag = 0

  IF et=39 THEN ; user type
    Print("TYPE=")
    name = e + 3
    next = name + name(0) + 1
    ch = '[
    oldT = 0
    WHILE next.vtype<128 DO
      et = next.vtype & $7
      If et=0 THEN EXIT FI
      IF et=oldT THEN
        Print(", ")
      ELSE
        Put(ch)
        BaseType(et)
        Put(' )
      FI
      oldT = et
      Print(name)
      ch = ' 
      name = next + 3
      next = name + name(0) + 1
    OD
    IF ch='[ THEN Put('[) FI
    Put('])
    RETURN(0)
  FI

  IF et=27 THEN ; DEFINE
    PrintF("DEFINE = ""%S""", e+3)
    RETURN(0)
  FI

; get basic type
  BaseType(et)

; only record vars less than 128
  IF et<128 THEN ; record
    IF (et&7)=0 THEN
      Print("RECORD")
      IF (et&8)=8 THEN
        Print(" POINTER")
      FI
    ELSE
      Print(" record field")
    FI
    RETURN(0)
  FI
               
  IF et&$10 THEN ; ARRAY
    Print(" ARRAY")
  ELSEIF et&$40 THEN ; PROC or FUNC
    pfFlag = 1
    IF (et&$F7)=$C0 THEN ; PROC
      Print("PROC")
    ELSE ; FUNC
      Print(" FUNC")
    FI
  FI
RETURN(pfFlag)


PROC PrintEntry(STRING n)
  DEFINE MAX = "15"
  BYTE i, et
  STRING name(MAX+1), t
  BYTE ARRAY argTypes

; get the name
  SetBlock(name+1, MAX, '.)
  SCopyS(name, n, 1, MAX)
  name(0) = MAX

; get address of entry info
  e = n + n(0) + 1
  
  et = e.vtype
  IF et=$88 THEN RETURN FI ; undeclared

  PrintF("%S ",name)

  IF et=27 THEN ; DEFINE
    Print("     ")
  ELSE
    PrintH(e.adr)
  FI
  Put(' )

  IF GetType(et) THEN ; PROC or FUNC
    Put('()
    argTypes = e + 3
    t=""
    FOR i = 1 TO e.numargs DO
      Print(t)
      GetType(argTypes(i)%$80)
      t = ", "
    OD
    Put('))
  FI

  PutE()
RETURN


PROC DumpST(CARD POINTER base)
  CARD loc, i
  BYTE low=loc, high=loc+1, ibest
  BYTE ARRAY stLow, stHigh, flags(256)
  STRING best, worst(0)="|"

  Zero(flags, 256)
  stHigh = base^
  stLow = stHigh + 256

  DO
    best = worst
    FOR i = 0 TO 255 DO
      high = stHigh(i)
      IF high#0 AND flags(i)=0 THEN
        low = stLow(i)
        IF SCompare(loc, best)<0 THEN
          best = loc
          ibest = i
        FI
      FI
    OD
  
    IF best=worst THEN EXIT FI

    flags(ibest) = 1
    PrintEntry(best)
  OD
RETURN


PROC Save()
; save state of variables used by
; both compiler and library routines

  bank(0) = 0 ; init library routines
  tZop = Zop
  MoveBlock(zpage, $B0, $1B) ; to $CA
  MoveBlock(temps, $5F0, 16)

  device = 5
RETURN


PROC Restore()
; restore state of variables used by
; both compiler and library routines

  Zop = tZop
  MoveBlock($B0, zpage, $1B) ; to $CA
  MoveBlock($5F0, temps, 16)

; device = oldDevice
  bank(curBank) = 0
RETURN


PROC SegEnd()
  Save()
  IF pf THEN ; print locals
    PrintF("%ELocal declarations for %S:%E", curproc)
    DumpST($B3)
  ELSE
    pf = 1
  FI
  Restore()
RETURN


BYTE FUNC DclEnd()
  BYTE token=$C2
  CARD addr1, addr2

  DEFINE PLA = "$68",
         STA = "$8D",
         LDA = "$AD",
         PHA = "$48"

; find out where we came from
  [   
    PLA
    STA addr1
    PLA
    STA addr1+1
    PLA
    STA addr2
    PLA
    STA addr2+1
    PHA
    LDA addr2
    PHA
    LDA addr1+1
    PHA
    LDA addr1
    PHA
  ]
  IF addr2<$B000 THEN ; new MODULE
    SegEnd()
    pf = 0
  FI
RETURN(token)


PROC SPL() ; dummy proc for call below


PROC SPLEnd()
  BYTE nxttoken=$D3
  CARD codeBase=$491, codeSize=$493
  CARD nxtaddr=$C9
  STRING inbuf(0)=$5C8, name

  DEFINE PLA = "$68",
         STA = "$8D"

; oldDevice = device
  Save()

  Close(5)  Open(5, "P:", 8)

  IF nxttoken=30 THEN ; command line
    name = nxtaddr
  ELSE ; editor buffer
    name = inbuf
  FI
  PrintF("%E%ESymbol Table for %S%E%E", name)

  pf = 0 ; no proc decl yet

; JSR for return so that we come
; back here after compilation
  [   
    PLA
    STA SPL+1
    PLA
    STA SPL+2
  ]
  SPL = SPL + 1 ; get right address
  Restore()
  SPL()

  Save()

  IF pf THEN ; print locals
    PrintF("%ELocal declarations for %S:%E", curproc)
    DumpST($B3)
  FI

  PrintF("%E%EGlobal declarations:%E%E")
  DumpST($B1)

  PrintF("%E%ECode base = %H, code size = %U%E",
         codeBase, codeSize)

  Close(5)
  Restore()
RETURN


; only code generated before Init is
; allocated space.  Init will be
; garbage collected (well kind of).

PROC Init()
  CARD codeBlock, bsize, csize, nBlock
  CARD POINTER cur, next
  CARD ARRAY codeBase=$491

; link in our routines
  Segvec.op = JMP
  Segvec.addr = SegEnd
  Dclvec.op = JMP
  Dclvec.addr = DclEnd
  SPLvec.op = JMP
  SPLvec.addr = SPLEnd

; allocate our routine so it won't
; go away.
  codeBlock = codeBase^ - 4
  next = $80 ; AFbase
  DO
    cur = next
    next = next^
  UNTIL next=0 OR next=codeBlock OD

  IF next=0 THEN
    PutE()   Put($FD)
    PrintE("I can't allocate space for your code")
    PrintE("You better Boot and try again!")
    RETURN
  FI

; assume we can split block
  csize = @codeBlock-codeBlock
  nBlock = next^
  bsize = next(1) - csize
  next = @codeBlock
  cur^ = next
  next^ = nBlock
  next(1) = bsize
  codeBase^ = @codeBlock
RETURN