The QBasic / QB64 Discussion Forum      Other Subforums, Links and Downloads
 
 

 Return to Index  

xl0c.bas (abandoned)

August 14 2017 at 3:00 PM
Michael Calkins  (Login MCalkins)
ASM Forum


Response to (not QB, but we don't have a misc forum anymore) xl0 abandonded

 
'reexamine .com stack checking.

' will eventually have to add expression evaluation.
' am avoiding it for now.

'eXpirimental Language 0 Compiler.
'Originally called "Medium Level Basic Compiler"
'By Michael Calkins.
'Started on the compiler February 24, 2011. Started on the language a few days
'before that.

'this program assumes all variables are initiallized to 0, which is the case
'in QBASIC, and probably QB64 also.

CONST inf$ = "c:\xl0\t.xl0"
CONST outf$ = "c:\xl0\t.asm"
CONST pmode = 0
CONST os = "dos"
CONST ttype = "com"

CONST majorversion = 0
CONST minorversion = 0
CONST revision = &H20110330
CONST langmajorversion = 0
CONST langminorversion = 0

CONST maxdatatypes = 256
CONST maxelements = 512
CONST maxvariables = 1024 'variables and arrays
CONST maxarrays = 256 'arrays only
CONST maxfunctions = 256
CONST maxblks = 64
CONST maxconsts = 64

CONST txt = 0
CONST dat = 1
CONST bss = 2

DEFINT A-Z
DECLARE FUNCTION isexpected% (t$, i%)
DECLARE FUNCTION getconstbyte$ (t$, i%)
DECLARE FUNCTION getconstword% (t$, i%)
DECLARE FUNCTION readword% (t$)
DECLARE FUNCTION readbyte$ (t$)
DECLARE SUB verifyint (t$)
DECLARE FUNCTION getconstwordseq% (t$, i%, sup%)
DECLARE FUNCTION getconstbyteseq$ (t$, i%, sup%)
DECLARE FUNCTION getconstqwordseq$ (t$, i%, sup%)
DECLARE FUNCTION getconsttwordseq$ (t$, i%, sup%)
DECLARE FUNCTION getsequence$ (t$, i%)
DECLARE FUNCTION getconstdwordseq& (t$, i%, sup%)
DECLARE SUB warn (n AS INTEGER)
DECLARE SUB checkid (t$)
DECLARE SUB process (t$)
DECLARE FUNCTION getconstdword& (t$, i%)
DECLARE SUB bomb (n%, t$)
DECLARE SUB section (n AS INTEGER)
DECLARE FUNCTION readdword& (t$)
DECLARE SUB processfile (f$)
DECLARE FUNCTION nextword$ (t$, i%)
DIM SHARED dt(0 TO maxdatatypes - 1) AS STRING 'name of data type
DIM SHARED dte(0 TO maxdatatypes - 1) AS STRING 'list of elements
'will be a sequence of INTEGER indexes into the array of elements
DIM SHARED dts(0 TO maxdatatypes - 1) AS LONG 'size of data type
DIM SHARED el(0 TO maxelements - 1) AS STRING 'name of element
DIM SHARED elo(0 TO maxelements - 1) AS LONG 'offset within data type
DIM SHARED eld(0 TO maxelements - 1) AS INTEGER 'data type of element
DIM SHARED els(0 TO maxelements - 1) AS LONG 'size of element
'type * factor will be accomplished by storing the resulting size, instead of
'the size of the plain type.
DIM SHARED va(0 TO maxvariables - 1) AS STRING 'name of variable or array
DIM SHARED vadt(0 TO maxvariables - 1) AS INTEGER 'index into array of types
DIM SHARED vaf(0 TO maxvariables - 1) AS INTEGER 'index into array of funcs
'if the variable is local to a function, the high bit is set, and the other
'bits are an index into the array of functions.
DIM SHARED vadi(0 TO maxvariables - 1) AS INTEGER 'link to dimension info
'if high bit clear, variable is not an array. if high bit set, the variable is
'an array, in which case the 2nd highest bit is set if column major, clear if
'row major, and the other bits are an index into the array of dimensions.
DIM SHARED vas(0 TO maxvariables - 1) AS LONG 'size of variable
DIM SHARED adi(0 TO maxarrays - 1) AS STRING 'list of array upper bounds
'will be a sequence of LONGs
DIM SHARED aes(0 TO maxarrays - 1) AS LONG 'size of element
'type * factor will be accomplished by storing the resulting size, instead of
'the size of the plain type.
DIM SHARED fu(0 TO maxfunctions - 1) AS STRING 'function name
DIM SHARED fur(0 TO maxfunctions - 1) AS INTEGER 'function return data type
'if high bit set, function returns a floating point. The other bits are an
'index into the array of data types. If 0, function is void.
DIM SHARED fup(0 TO maxfunctions - 1) AS STRING 'list of parameters
'will be a sequence of LONGS. The high 16 bits are the size of the parameter.
'The low 16 bits are an index into the array of data types.
DIM SHARED fus(0 TO maxfunctions - 1) AS INTEGER 'info about the function
'the high 3 bits indicate the calling convention. the low ten bits are the
'number of words pushed onto the stack. The other bits are currently reserved.
'calling conventions:
'w32 stdcall 0
'cdecl 1
'pascal 2
'w32 fastcall 3
'os2 syscall 4
'reserved 5 to 7
DIM SHARED funv(0 TO maxfunctions - 1) AS INTEGER 'next variable
'defines the next valid end offset for a local variable. for example, if this
'number is 0, the next local variable may end at (ebp-1), and start at
'((ebp-1)-lengthofvariable).
DIM SHARED constname(0 TO maxconsts - 1) AS STRING 'name of const
DIM SHARED constvalue(0 TO maxconsts - 1) AS LONG 'value of const

DIM SHARED ndt AS INTEGER 'num of data types
DIM SHARED nel AS INTEGER 'num of elements
DIM SHARED nva AS INTEGER 'num of variables
DIM SHARED nar AS INTEGER 'num of arrays
DIM SHARED nfu AS INTEGER 'num of functions
DIM SHARED nco AS INTEGER 'num of consts

DIM SHARED blktype(0 TO maxblks - 1) AS INTEGER 'type of block
'0=function, 1=if, 2=select, 3=do, 4=for, 6=$if
DIM SHARED blknum(0 TO maxblks - 1) AS LONG 'unique id, if needed
'in the case of functions, will be an index into array of funcs
'in the case of $if, will be 1 if the block has already had a true condition,
'2 if it has already had an $else, otherwise 0.
DIM SHARED blkstack AS INTEGER 'number of blocks currently active
DIM SHARED blknextnum AS LONG 'the next available unique id
DIM SHARED currentsection AS INTEGER 'the current output section
DIM SHARED curfil AS STRING 'current source file
DIM SHARED curlin AS LONG 'current line number
DIM SHARED dataalign AS LONG
DIM SHARED bssalign AS LONG
DIM SHARED biggestdataalign AS LONG
DIM SHARED biggestbssalign AS LONG


dt(0) = "void"
dte(0) = ""
dts(0) = 0
dt(1) = "byte"
dte(1) = ""
dts(1) = 1
dt(2) = "word"
dte(2) = ""
dts(2) = 2
dt(3) = "dword"
dte(3) = ""
dts(3) = 4
dt(4) = "qword"
dte(4) = ""
dts(4) = 8
dt(5) = "tword"
dte(5) = ""
dts(5) = 10

constname(0) = "stackalign"
IF pmode THEN constvalue(0) = 4 ELSE constvalue(0) = 2

ndt = 6
nel = 0
nva = 0
nar = 0
nfu = 0
nco = 1

blknextnum = 0
blkstack = 0

DIM SHARED ulu AS STRING 'unicode lookup table
ulu = "263a263b2665266626632660202225d825cb25d926422640266a266b263c"
ulu = ulu + "25ba25c42195203c00b600a725ac21a82191219321922190221f219425b225bc"
ulu = ulu + "2302"
ulu = ulu + "00c700fc00e900e200e400e000e500e700ea00eb00e800ef00ee00ec00c400c5"
ulu = ulu + "00c900e600c600f400f600f200fb00f900ff00d600dc00a200a300a520a70192"
ulu = ulu + "00e100ed00f300fa00f100d100aa00ba00bf231000ac00bd00bc00a100ab00bb"
ulu = ulu + "259125922593250225242561256225562555256325512557255d255c255b2510"
ulu = ulu + "25142534252c251c2500253c255e255f255a25542569255625602550256c2567"
ulu = ulu + "2568256425652559255825522553256b256a2518250c25882584258c25902580"
ulu = ulu + "03b100df039303c003a303c300b503c403a6039803a903b4221e03c603b52229"
ulu = ulu + "226100b1226522642320232100f7224800b0221900b7221a207f00b225a000a0"

PRINT "eXpirimental Language 0 Compiler"
PRINT "Public Domain. Written by Michael Calkins. http://www.qbasicmichael.com"
PRINT "http://www.network54.com/index/10167"
PRINT "Version:"; STR$(majorversion); "."; LTRIM$(STR$(majorversion)); ", Revision: "; HEX$(revision);
PRINT ", Supported language version:"; STR$(langmajorversion); "."; LTRIM$(STR$(langmajorversion))
OPEN outf$ FOR OUTPUT AS 1
PRINT #1, "_stackalign equ 0x"; HEX$(constvalue(0))
PRINT #1, "section .text align=0x1"
PRINT #1, "section .data align=0x1"
PRINT #1, "section .bss align=0x1"
dataalign = 1
bssalign = 1
currentsection = bss
processfile inf$
CLOSE
SYSTEM

SUB bomb (n, t$)
 PRINT
 PRINT "Error in "; CHR$(&H22); curfil; CHR$(&H22); ", line"; curlin
 SELECT CASE n
 CASE 0: PRINT "Syntax error."
 CASE 1: PRINT "Feature not yet implemented."
 CASE 2: PRINT "Unknown identifier."
 CASE 3: PRINT "Block mismatch or syntax error."
 CASE 4: PRINT "Reached end of file while inside block."
 CASE 5: PRINT "Invalid identifier."
 CASE 6: PRINT "Duplicate definition."
 CASE 7: PRINT "Data type mismatch."
 END SELECT
 IF LEN(t$) THEN PRINT t$
 CLOSE
 KILL outf$
 SYSTEM
END SUB

SUB checkid (t$)
'checks an identifier to make sure it is valid, and isn't reserved.

END SUB

FUNCTION getconstbyte$ (t$, i)
'evaluates a byte constant
'adjusts i in the same way that nextword$ does.

'it could be a constant expression. but for now, just read it as a simple
'literal

 getconstbyte$ = readbyte$(nextword$(t$, i))
END FUNCTION

FUNCTION getconstbyteseq$ (t$, i, sup)
'evaluates byte constant or sequence up to byte size, and returns a byte.
'adjusts i in the same way that nextword$ does.

 IF MID$(t$, i) = "(" THEN
  SELECT CASE LCASE$(nextword$(t$, i + 1)) 'i is not affected
  CASE "byte", "word", "dword", "qword", "tword", "alit", "wlit"
   t$ = getsequence$(t$, i)
   IF sup THEN
    SELECT CASE LEN(t$)
    CASE IS < 1: warn 6
    CASE IS > 1: bomb 7, "Initiallization value is too big."
    END SELECT
   ELSE
    IF LEN(t$) <> 1 THEN bomb 7, "Expected: BYTE constant."
   END IF
   getconstbyteseq$ = t$
  CASE ELSE
   getconstbyteseq$ = getconstbyte$(t$, i)
  END SELECT
 ELSE
  getconstbyteseq$ = getconstbyte$(t$, i)
 END IF

END FUNCTION

FUNCTION getconstdword& (t$, i)
'evaluates a dword constant
'adjusts i in the same way that nextword$ does.

'it could be a constant expression. but for now, just read it as a simple
'literal
 
 getconstdword& = readdword&(nextword$(t$, i))
END FUNCTION

FUNCTION getconstdwordseq& (t$, i, sup)
'evaluates dword constant or sequence up to dword size, and returns a dword.
'adjusts i in the same way that nextword$ does.
 IF MID$(t$, i) = "(" THEN
  SELECT CASE LCASE$(nextword$(t$, i + 1)) 'i is not affected
  CASE "byte", "word", "dword", "qword", "tword", "alit", "wlit"
   t$ = getsequence$(t$, i)
   IF sup THEN
    SELECT CASE LEN(t$)
    CASE IS < 4: warn 6
    CASE IS > 4: bomb 7, "Initiallization value is too big."
    END SELECT
   ELSE
    IF LEN(t$) <> 4 THEN bomb 7, "Expected: DWORD constant."
   END IF
   getconstdwordseq& = CVL(t$)
  CASE ELSE
   getconstdwordseq& = getconstdword&(t$, i)
  END SELECT
 ELSE
  getconstdwordseq& = getconstdword&(t$, i)
 END IF
END FUNCTION

FUNCTION getconstqwordseq$ (t$, i, sup)
'evaluates qword constant or sequence up to qword size, and returns a qword.
'adjusts i in the same way that nextword$ does.
 IF MID$(t$, i) = "(" THEN
  SELECT CASE LCASE$(nextword$(t$, i + 1)) 'i is not affected
  CASE "byte", "word", "dword", "qword", "tword", "alit", "wlit"
   t$ = getsequence$(t$, i)
   IF sup THEN
    SELECT CASE LEN(t$)
    CASE IS < 8: warn 6
    CASE IS > 8: bomb 7, "Initiallization value is too big."
    END SELECT
   ELSE
    IF LEN(t$) <> 8 THEN bomb 7, "Expected: QWORD constant."
   END IF
   getconstqwordseq$ = t$
  CASE ELSE
   bomb 1, "QWORD literals are not yet supported."
  END SELECT
 ELSE
  bomb 1, "QWORD literals are not yet supported."
 END IF
END FUNCTION

FUNCTION getconsttwordseq$ (t$, i, sup)
'evaluates qword constant or sequence up to qword size, and returns a qword.
'adjusts i in the same way that nextword$ does.
 IF MID$(t$, i) = "(" THEN
  SELECT CASE LCASE$(nextword$(t$, i + 1)) 'i is not affected
  CASE "byte", "word", "dword", "qword", "tword", "alit", "wlit"
   t$ = getsequence$(t$, i)
   IF sup THEN
    SELECT CASE LEN(t$)
    CASE IS < 10: warn 6
    CASE IS > 10: bomb 7, "Initiallization value is too big."
    END SELECT
   ELSE
    IF LEN(t$) <> 10 THEN bomb 7, "Expected: TWORD constant."
   END IF
   getconsttwordseq$ = t$
  CASE ELSE
   bomb 1, "TWORD literals are not yet supported."
  END SELECT
 ELSE
  bomb 1, "QWORD literals are not yet supported."
 END IF
END FUNCTION

FUNCTION getconstword% (t$, i)
'evaluates a word constant
'adjusts i in the same way that nextword$ does.

'it could be a constant expression. but for now, just read it as a simple
'literal

 getconstword% = readword%(nextword$(t$, i))
END FUNCTION

FUNCTION getconstwordseq% (t$, i, sup)
'evaluates word constant or sequence up to word size, and returns a word.
'adjusts i in the same way that nextword$ does.

 IF MID$(t$, i) = "(" THEN
  SELECT CASE LCASE$(nextword$(t$, i + 1)) 'i is not affected
  CASE "byte", "word", "dword", "qword", "tword", "alit", "wlit"
   t$ = getsequence$(t$, i)
   IF sup THEN
    SELECT CASE LEN(t$)
    CASE IS < 2: warn 6
    CASE IS > 2: bomb 7, "Initiallization value is too big."
    END SELECT
   ELSE
    IF LEN(t$) <> 2 THEN bomb 7, "Expected: WORD constant."
   END IF
   getconstwordseq% = CVI(t$)
  CASE ELSE
   getconstwordseq% = getconstword%(t$, i)
  END SELECT
 ELSE
  getconstwordseq% = getconstword%(t$, i)
 END IF
END FUNCTION

FUNCTION getsequence$ (t$, i)
 DIM a$
 IF MID$(t$, i, 1) <> "(" THEN bomb 0, "Sequences must be within parenthesis. Expected: (."
 i = i + 1
 DO
  SELECT CASE LCASE$(nextword$(t$, i))
  CASE "byte": a$ = a$ + getconstbyte$(t$, i)
  CASE "word": a$ = a$ + MKI$(getconstword%(t$, i))
  CASE "dword": a$ = a$ + MKD$(getconstdword&(t$, i))
  CASE "qword": bomb 1, "QWORD literals are not yet supported."
  CASE "tword": bomb 1, "TWORD literals are not yet supported."
  CASE "alit"
   IF MID$(t$, i, 1) = " " THEN i = i + 1
   IF MID$(t$, i, 1) <> CHR$(&H22) THEN bomb 0, "Expected: " + CHR$(&H22) + "."
   DO
    i = i + 1
    IF MID$(t$, i, 1) = CHR$(&H22) THEN EXIT DO
    a$ = a$ + MID$(t$, i, 1)
   LOOP
   i = i + 1
  CASE "wlit"
   IF MID$(t$, i, 1) = " " THEN i = i + 1
   IF MID$(t$, i, 1) <> CHR$(&H22) THEN bomb 0, "Expected: " + CHR$(&H22) + "."
   DO
    i = i + 1
    IF MID$(t$, i, 1) = CHR$(&H22) THEN EXIT DO
    n = ASC(MID$(t$, i, 1))
    SELECT CASE n
    CASE &H1 TO &H1F: a$ = a$ + MKI$(VAL("&h" + MID$(ulu, 1 + (4 * (n - 1)), 4)))
    CASE IS > &H7E: a$ = a$ + MKI$(VAL("&h" + MID$(ulu, 1 + (4 * (n - &H60)), 4)))
    CASE ELSE: a$ = a$ + MKI$(n)
    END SELECT
   LOOP
   i = i + 1
  CASE ELSE: bomb 0, "Expected: standard data type or ALIT or WLIT."
  END SELECT
  SELECT CASE MID$(t$, i, 1)
  CASE ",": i = i + 1
  CASE ")": i = i + 1: EXIT DO
  CASE ELSE: bomb 0, "Expected: , or )."
  END SELECT
 LOOP
 IF i > LEN(t$) THEN i = 0
 getsequence$ = a$
END FUNCTION

FUNCTION isexpected% (t$, i)
'returns true if the specified quote enclosed string contains an output mode
'that matches the current output mode.

'adjusts i like nextword$

 IF MID$(t$, i, 1) <> CHR$(&H22) THEN bomb 0, "Expected: " + CHR$(&H22) + "."
 i = i + 1
 DO
  thismatches = -1
  n = INSTR(i, t$, ":"): last = 0
  IF n = 0 THEN n = INSTR(i, t$, ","): last = 1
  IF n = 0 THEN n = INSTR(i, t$, CHR$(&H22)): last = 2
  IF n = 0 THEN bomb 0, "Can't find : or , or " + CHR$(&H22) + "."
  w$ = LCASE$(MID$(t$, i, n - i))
  SELECT CASE w$
  CASE "p": IF pmode = 0 THEN thismatches = 0
  CASE "r": IF pmode THEN thismatches = 0
  CASE "a"
  CASE ELSE: bomb 0, "Expected: A or P or R."
  END SELECT
  i = n + 1
  IF last THEN EXIT DO
  n = INSTR(i, t$, ":"): last = 0
  IF n = 0 THEN n = INSTR(i, t$, ","): last = 1
  IF n = 0 THEN n = INSTR(i, t$, CHR$(&H22)): last = 2
  IF n = 0 THEN bomb 0, "Can't find : or , or " + CHR$(&H22) + "."
  w$ = LCASE$(MID$(t$, i, n - i))
  SELECT CASE w$
  CASE "win": IF os <> "win" THEN thismatches = 0
  CASE "dos": IF os <> "dos" THEN thismatches = 0
  CASE "os2": IF os <> "os2" THEN thismatches = 0
  CASE "a"
  CASE ELSE: warn 8
  END SELECT
  i = n + 1
  IF last THEN EXIT DO
  n = INSTR(i, t$, ":"): last = 0
  IF n = 0 THEN n = INSTR(i, t$, ","): last = 1
  IF n = 0 THEN n = INSTR(i, t$, CHR$(&H22)): last = 2
  IF n = 0 THEN bomb 0, "Can't find : or , or " + CHR$(&H22) + "."
  w$ = LCASE$(MID$(t$, i, n - i))
  SELECT CASE w$
  CASE "qbasic": IF ttype <> "qbasic" THEN thismatches = 0
  CASE "com": IF ttype <> "com" THEN thismatches = 0
  CASE "module": IF ttype <> "module" THEN thismatches = 0
  CASE "a"
  CASE ELSE: warn 8
  END SELECT
  i = n + 1
  IF last = 0 THEN
   warn 9
   n = INSTR(i, t$, ","): last = 1
   IF n = 0 THEN n = INSTR(i, t$, CHR$(&H22)): last = 2
   IF n = 0 THEN bomb 0, "Can't find , or " + CHR$(&H22) + "."
   i = n + 1
  END IF
  IF last THEN
   IF thismatches THEN match = -1
   'the loop is not exited so that the syntax of the rest of the string can be
   'checked.
  END IF
 LOOP UNTIL last = 2
 IF i > LEN(t$) THEN i = 0
 isexpected% = match
END FUNCTION

FUNCTION nextword$ (t$, i)
'starts searching a string at position i. skips initial spaces, starts when it
'encounters a non-space, stops when it encounters a space, a parenthesis, a
'comma, or a period. the found string is returned, and i will be the position
'after the end of the found string. If the end of the string has been reached,
'i will be 0.
DIM c AS STRING * 1
 IF i = 0 THEN bomb 0, "Unexpectedly reached end of line."
 n$ = ""
 m = 0
 DO WHILE i <= LEN(t$)
  c = MID$(t$, i, 1)
  i = i + 1
  SELECT CASE c
  CASE " ": IF m THEN EXIT DO
  CASE "(", ")", ".", ",": EXIT DO
  CASE ELSE
   m = -1
   n$ = n$ + c
  END SELECT
 LOOP
 IF i > LEN(t$) THEN i = 0
 nextword$ = n$
END FUNCTION

SUB process (t$)
'processes a line of source code: removes comments and redundant spaces.
'remove any space after a space, comma, period, or left parenthesis
 t$ = LTRIM$(RTRIM$(t$))
 outquote = 0
 killspace = 0
 i = 1
 DO UNTIL i >= LEN(t$)
  SELECT CASE MID$(t$, i, 1)
  CASE CHR$(&H22): outquote = NOT outquote
  CASE "'"
   IF outquote THEN t$ = RTRIM$(LEFT$(t$, i - 1)): EXIT DO
  CASE ",", ".", "(": killspace = -1
  CASE " "
   IF killspace AND outquote THEN t$ = LEFT$(t$, i - 1) + MID$(t$, i + 1)
   killspace = -1
  CASE ELSE: killspace = 0
  END SELECT
  i = i + 1
 LOOP
END SUB

SUB processfile (f$)
 curfil = f$
 DIM lin AS LONG
 PRINT
 PRINT "Beginning to process file: "; f$
 fln = FREEFILE
 OPEN f$ FOR INPUT AS fln
 lin = 0
 notskip = -1
 DO UNTIL EOF(fln)
  lin = lin + 1
  curlin = lin
  LINE INPUT #fln, t$
  process t$
  i = 1
  w$ = nextword(t$, i)
  IF (fln = 2) AND (curlin = 1) THEN
   IF (pmode = 0) AND (os = "dos") AND (ttype = "com") AND (LCASE$(w$) <> "stack") THEN
    bomb 0, "In r:dos:com mode, STACK must be the first line."
   END IF
  END IF
  SELECT CASE LCASE$(w$)
  CASE "$elseif"
   IF blkstack = 0 THEN bomb 3, "$elseif without $if."
   IF blktype(blkstack - 1) <> 6 THEN bomb 3, "$elseif without $if."
   notskip = 0
   IF blknum(blkstack - 1) = 2 THEN bomb 3, "$elseif after $else."
   IF blknum(blkstack - 1) = 0 THEN
    IF i = 0 THEN bomb 0, "Expected: " + CHR$(&H22) + "."
    IF isexpected%(t$, i) = 0 THEN
     blknum(blkstack - 1) = 1
     notskip = -1
    END IF
    IF i THEN bomb 0, "Expected: end of line."
   END IF
  CASE "$else"
   IF i THEN bomb 0, "Expected: end of line."
   IF blkstack = 0 THEN bomb 3, "$else without $if."
   IF blktype(blkstack - 1) <> 6 THEN bomb 3, "$else without $if."
   IF blknum(blkstack - 1) THEN
    notskip = 0
   ELSE
    notskip = -1
   END IF
   blknum(blkstack - 1) = 2
  CASE "$end"
   IF i THEN bomb 0, "Expected: end of line."
   IF blkstack = 0 THEN bomb 3, "$end without $if."
   IF blktype(blkstack - 1) <> 6 THEN bomb 3, "$end without $if."
   notskip = -1
   blkstack = blkstack - 1
  CASE ELSE
   IF notskip THEN
    SELECT CASE LCASE$(w$)
    CASE "$if"
     IF i = 0 THEN bomb 0, "Expected: " + CHR$(&H22) + "."
     blktype(blkstack) = 6
     IF isexpected%(t$, i) = 0 THEN
      blknum(blkstack) = 1
      notskip = -1
     ELSE
      blknum(blkstack) = 0
      notskip = 0
     END IF
     blkstack = blkstack + 1
     IF i THEN bomb 0, "Expected: end of line."
    CASE "$include"
     IF MID$(t$, i, 2) <> MKI$(&H2220) THEN bomb 0, "Expected: " + CHR$(&H22) + "."
     i = i + 2
     n = INSTR(i, t$, CHR$(&H22))
     if$ = MID$(t$, i, n - i)
     i = n + 1
     IF n <= LEN(t$) THEN bomb 0, "Expected: end of line."
     processfile if$
    CASE "$language"
    CASE "$expected"
     IF i = 0 THEN bomb 0, "Expected: " + CHR$(&H22) + "."
     IF isexpected%(t$, i) = 0 THEN warn 4
     IF i THEN bomb 0, "Expected: end of line."
    CASE "asm"
     section txt
     DO
      IF EOF(fln) THEN bomb 4, "Still inside ASM block."
      LINE INPUT #fln, t$
      lin = lin + 1
      curlin = lin
      IF LCASE$(nextword$(t$, 1)) = "end" THEN EXIT DO
      PRINT #1, t$
     LOOP
    CASE "stack"
     IF (fln > 2) OR (curlin > 1) THEN bomb 0, "STACK can only be in the first line in the main source file."
     w$ = nextword$(t$, i)
     IF i THEN
      IF MID$(t$, i, 1) <> "," THEN bomb 0, "Expected: , or end of line."
      n = getconstword%(t$, i)
      IF i THEN bomb 0, "Expected: end of line."
     ELSE
      n = &H4000
     END IF
     IF n < &H1000 THEN warn 7
     IF (pmode = 0) AND (os = "dos") THEN
      SELECT CASE ttype
      CASE "com"
       PRINT #1, "org 0x100"
       PRINT #1, "section .stack nobits"
       PRINT #1, "stackbottom:"
       PRINT #1, "section .text"
       currentsection = txt
       PRINT #1, "mov ax,sp"
       PRINT #1, "sub ax,stackbottom"
       PRINT #1, "cmp ax,0x"; HEX$(n)
'this is used instead of cmp sp,stackbottom+n because if stackbottom+n is >
'0xffff, then cmp sp,stackbottom+n won't set the carry flag.
       PRINT #1, "jb stackerror"
       PRINT #1, "push cs"
       PRINT #1, "call _"; w$; "@0"
       PRINT #1, "xor ah,ah"
       PRINT #1, "int 0x21"
       PRINT #1, "stackerror:"
       PRINT #1, "mov ah,0x9"
       PRINT #1, "mov dx,stackmsg"
       PRINT #1, "int 0x21"
       PRINT #1, "xor ah,ah"
       PRINT #1, "int 0x21"
       PRINT #1, "stackmsg:"
       PRINT #1, "db 'Error: Insufficient stack space.',0xd,0xa,'$'"
      CASE "module"
       PRINT #1, "section .stack stack"
       PRINT #1, "stackbottom:"
       PRINT #1, "resb 0x"; HEX$(n)
       PRINT #1, "stacktop:"
       PRINT #1, "section .text"
       currentsection = txt
       PRINT #1, "..start:"
       PRINT #1, "mov ax,stack"
       PRINT #1, "mov ss,ax"
       PRINT #1, "mov sp,stacktop"
       PRINT #1, "mov ax,.data"
       PRINT #1, "mov ds,ax"
       PRINT #1, "mov es,ax"
       PRINT #1, "call far _"; w$; "@0"
       PRINT #1, "mov ah,0x4c"
       PRINT #1, "int 0x21"
      END SELECT
     END IF
    CASE "sectionalign"
     dataalign = getconstdword&(t$, i)
     PRINT #1, "section .data align=0x"; HEX$(dataalign)
     IF MID$(t$, i, 1) <> "," THEN bomb 0, "Expected: ,."
     i = i + 1
     bssalign = getconstdword&(t$, i)
     PRINT #1, "section .bss align=0x"; HEX$(bssalign)
     currentsection = bss
     IF i THEN bomb 0, "Expected: end of line."
    CASE "const"
     constname(nco) = nextword$(t$, i)
     IF nextword$(t$, i) <> "=" THEN bomb 0, "Expected: =."
     constvalue(nco) = getconstdwordseq&(t$, i, 0)
     PRINT #1, "_"; constname(nco); " equ "; 0; x; ";hex$(constvalue(nco))"
     nco = nco + 1
     IF i THEN bomb 0, "Expected: end of line."
    CASE "type"
     dt(ndt) = nextword$(t$, i)
     checkid dt(ndt)
     DO
      IF EOF(fln) THEN bomb 4, "Still inside TYPE block."
      LINE INPUT #fln, t$
      lin = lin + 1
      curlin = lin
      process t$
      i = 1
      w$ = nextword$(t$, i)
      SELECT CASE w$
      CASE "union"
       union = &H80000000 OR nel
       el(nel) = nextword$(t$, i)
       elo(nel) = dts(ndt)
       PRINT #1, "_"; dt(ndt); "."; el(nel); " equ 0x"; HEX$(elo(nel))
       IF i THEN bomb 0, "Expected: end of line."
      CASE "end"
       IF union THEN
        dts(ndt) = dts(ndt) + els(union AND &H7FFFFFFF)
        PRINT #1, "_sizeof_"; dt(ndt); "."; el(union AND &H7FFFFFFF); " equ 0x"; HEX$(els(union AND &H7FFFFFFF))
        union = 0
        IF i THEN
         IF LCASE$(nextword(t$, i)) <> "union" THEN bomb 3, "Expected: UNION or end of line."
         IF i THEN bomb 0, "Expected: end of line."
        END IF
       ELSE
        IF i THEN
         IF LCASE$(nextword(t$, i)) <> "type" THEN bomb 3, "Expected: TYPE or end of line."
         IF i THEN bomb 0, "Expected: end of line."
        END IF
        EXIT DO
       END IF
      CASE ELSE
       dte(ndt) = dte(ndt) + MKI$(nel)
       el(nel) = w$
       checkid w$
       elo(nel) = dts(ndt)
       IF LCASE$(nextword(t$, i)) <> "as" THEN bomb 0, "Expected: AS."
       w$ = nextword(t$, i)
       FOR n = 1 TO 5
        'standard types are not case sensitive
        IF LCASE$(w$) = dt(n) THEN eld(nel) = n: EXIT FOR
       NEXT n
       IF eld(nel) = 0 THEN
        FOR n = 6 TO ndt - 1
         'udts are case sensitive
         IF w$ = dt(n) THEN eld(nel) = n: EXIT FOR
        NEXT n
        IF eld(nel) = 0 THEN bomb 2, "Failed to find the specified type."
        els(nel) = dts(eld(nel))
       ELSE
        IF i THEN
         IF nextword$(t$, i) <> "*" THEN bomb 0, "Expected: * or end of line."
         els(nel) = dts(eld(nel)) * getconstdword&(t$, i)
        END IF
       END IF
       PRINT #1, "_"; dt(ndt); "."; el(nel); " equ 0x"; HEX$(elo(nel))
       PRINT #1, "_sizeof_"; dt(ndt); "."; el(nel); " equ 0x"; HEX$(els(nel))
       IF union THEN
        IF els(nel) > els(union AND &H7FFFFFFF) THEN els(union AND &H7FFFFFFF) = els(nel)
       ELSE
        dts(ndt) = dts(ndt) + els(nel)
       END IF
       nel = nel + 1
       IF i THEN bomb 0, "Expected: end of line."
      END SELECT
     LOOP
     ndt = ndt + 1
    CASE "dim"
     m = 0
     IF blkstack THEN
      FOR n = 0 TO blkstack - 1
       IF blktype(n) = 0 THEN vaf(nva) = blknum(n): EXIT FOR
      NEXT
     END IF
     w$ = nextword$(t$, i)
     SELECT CASE LCASE$(w$)
     CASE "global"
      IF vaf(nva) THEN bomb 0, "GLOBAL not allowed inside function block."
      m = 1
      w$ = nextword$(t$, i)
     CASE "extern"
      IF vaf(nva) THEN bomb 0, "EXTERN not allowed inside function block."
      m = 2
      w$ = nextword$(t$, i)
     END SELECT
     SELECT CASE LCASE$(w$)
     CASE "rowmaj"
      m = m OR 4
      w$ = nextword$(t$, i)
     CASE "colmaj"
      m = m OR 8
      w$ = nextword$(t$, i)
     END SELECT
     checkid w$
     va(nva) = w$
     IF MID$(t$, i, 1) = "(" THEN
      i = i + 1
      s = 0
      vadi(nva) = &H8000 OR nar
      DO
       n = getconstdword&(t$, i)
       s = s * (n + 1)
       adi(nar) = adi(nar) + MKL$(n)
       SELECT CASE MID$(t$, i, 1)
       CASE ",": i = i + 1
       CASE ")": i = i + 1: EXIT DO
       CASE ELSE: bomb 0, "Expected: , or )."
       END SELECT
      LOOP
      IF LEN(adi(nar)) > 4 THEN
       IF (m AND &HC) = 0 THEN warn 1
       IF m AND &H8 THEN vadi(nva) = &HC000 OR nar
      ELSE
       IF m AND &HC THEN bomb 0, "ROWMAJ or COLMAJ is specified, but array has only 1 dimension."
      END IF
     END IF
     IF LCASE$(nextword(t$, i)) <> "as" THEN bomb 0, "Expected: AS."
     w$ = nextword(t$, i)
     FOR n = 1 TO 5
      'standard types are not case sensitive
      IF LCASE$(w$) = dt(n) THEN vadt(nva) = n: EXIT FOR
     NEXT n
     f = 1
     IF vadt(nva) = 0 THEN
      FOR n = 6 TO ndt - 1
       'udts are case sensitive
       IF w$ = dt(n) THEN vadt(nva) = n: EXIT FOR
      NEXT n
      IF vadt(nva) = 0 THEN bomb 2, "Failed to find the specified type."
     ELSE
      IF i THEN
       IF nextword$(t$, i) <> "*" THEN bomb 0, "Expected: * or end of line."
       f = getconstdword&(t$, i)
      END IF
     END IF
     IF vadi(nva) AND &H8000 THEN
      aes(nar) = dts(vadt(nva)) * f
      vas(nva) = aes(nar) * s
     ELSE
      vas(nva) = dts(vadt(nva)) * f
     END IF
     a = 1
     init = 0
     IF i THEN
      IF m AND 2 THEN bomb 0, "Expected: end of line."
      w$ = nextword$(t$, i)
      SELECT CASE LCASE$(w$)
      CASE "align"
       a = getconstdword&(t$, i)
       IF i THEN
        w$ = nextword$(t$, i)
       ELSE
        w$ = ""
       END IF
      CASE "="
      CASE ELSE
       IF vaf(nva) THEN
        bomb 0, "Expected: ALIGN or end of line."
       ELSE
        bomb 0, "Expected: ALIGN or = or end of line."
       END IF
      END SELECT
      SELECT CASE LCASE$(w$)
      CASE "="
       SELECT CASE vas(nva)
       CASE 1: t$ = getconstbyteseq$(t$, i, -1)
       CASE 2: t$ = MKI$(getconstwordseq%(t$, i, -1))
       CASE 4: t$ = MKL$(getconstdwordseq&(t$, i, -1))
       CASE 8: t$ = getconstqwordseq$(t$, i, -1)
       CASE 10: t$ = getconsttwordseq$(t$, i, -1)
       CASE ELSE
        t$ = getsequence$(t$, i)
        SELECT CASE LEN(t$)
        CASE IS < vas(nva): warn 6
        CASE IS > vas(nva): bomb 7, "Initiallization value is too big."
        END SELECT
       END SELECT
       init = -1
      CASE ""
      CASE ELSE
       IF vaf(nva) THEN
        bomb 0, "Expected: end of line."
       ELSE
        bomb 0, "Expected: = or end of line."
       END IF
      END SELECT
     END IF
     SELECT CASE a
     CASE 1, 2, 4, 8, 16
     CASE ELSE: bomb 0, "Invalid alignment."
     END SELECT
     SELECT CASE m AND 3
     CASE 1: PRINT #1, "global _"; va(nva)
     CASE 2: PRINT #1, "extern _"; va(nva)
     END SELECT
     IF vaf(nva) THEN
      IF a > constvalue(0) THEN warn 5
      s = funv(vaf(nva) AND &H7FFF)
      s = s + vas(nva)
      s = s + (a - (s MOD a))
      PRINT #1, "_"; fu(vaf(nva) AND &H7FFF); "_"; va(nva); " equ 0x"; HEX$(s + 1)
      funv(vaf(nva) AND &H7FFF) = s
      PRINT #1, "_sizeof_"; fu(vaf(nva) AND &H7FFF); "_"; va(nva); " equ 0x"; HEX$(vas(nva))
      IF vadi(nva) THEN PRINT #1, "_elementsizeof_"; fu(vaf(nva) AND &H7FFF); "_"; va(nva); " equ 0x"; HEX$(aes(nar))
     ELSE
      IF init THEN
       IF a > dataalign THEN warn 0
       section dat
       IF a > 1 THEN PRINT #1, "align 0x"; HEX$(a)
       PRINT #1, "_"; va(nva); ":"
       IF LEN(t$) >= 4 THEN
        PRINT #1, "dd ";
        DO WHILE LEN(t$) >= 4
         PRINT #1, "0x"; HEX$(CVL(LEFT$(t$, 4)))
         t$ = MID$(t$, 5)
         IF LEN(t$) >= 4 THEN PRINT #1, ",";
        LOOP
        PRINT #1, ""
       END IF
       IF LEN(t$) >= 2 THEN
        PRINT #1, "dw ";
        DO WHILE LEN(t$) >= 2
         PRINT #1, "0x"; HEX$(CVI(LEFT$(t$, 2)))
         t$ = MID$(t$, 3)
         IF LEN(t$) >= 2 THEN PRINT #1, ",";
        LOOP
        PRINT #1, ""
       END IF
       IF LEN(t$) THEN
        PRINT #1, "db ";
        DO WHILE LEN(t$)
         PRINT #1, "0x"; HEX$(ASC(LEFT$(t$, 1)))
         t$ = MID$(t$, 2)
         IF LEN(t$) THEN PRINT #1, ",";
        LOOP
        PRINT #1, ""
       END IF
      ELSE
       IF (m AND 2) = 0 THEN
        IF a > bssalign THEN warn 0
        section bss
        IF a > 1 THEN PRINT #1, "alignb 0x"; HEX$(a)
        PRINT #1, "_"; va(nva); ":"
        PRINT #1, "resb 0x"; HEX$(vas(nva))
       END IF
      END IF
      PRINT #1, "_sizeof_"; va(nva); " equ 0x"; HEX$(vas(nva))
      IF vadi(nva) THEN PRINT #1, "_elementsizeof_"; va(nva); " equ 0x"; HEX$(aes(nar))
     END IF
     IF vadi(nva) THEN nar = nar + 1
     nva = nva + 1
    CASE "end"
     SELECT CASE blktype(blkstack)
     END SELECT
    CASE ELSE
    END SELECT
   END IF
  END SELECT
 LOOP
 CLOSE fln
 PRINT
 PRINT "Done processing file: "; f$
END SUB

FUNCTION readbyte$ (t$)
'reads a decimal or hex integer byte.
 verifyint t$
 IF LEFT$(t$, 2) = "0x" THEN
  IF LEN(t$) > 4 THEN bomb 7, "Expected: WORD constant literal."
  readbyte$ = CHR$(VAL("&h" + MID$(t$, 3)))
 ELSE
  n& = VAL(t$)
  IF (n& < &H0) OR (n& > &HFF) THEN bomb 7, "Expected: WORD constant literal."
  readbyte$ = CHR$(VAL(t$))
 END IF
END FUNCTION

FUNCTION readdword& (t$)
'reads a decimal or hex integer dword.
 verifyint t$
 IF LEFT$(t$, 2) = "0x" THEN
  readdword& = VAL("&h" + MID$(t$, 3))
 ELSE
  readdword& = VAL(t$)
 END IF
END FUNCTION

FUNCTION readword% (t$)
'reads a decimal or hex integer word.
 verifyint t$
 IF LEFT$(t$, 2) = "0x" THEN
  IF LEN(t$) > 6 THEN bomb 7, "Expected: WORD constant literal."
  readword% = VAL("&h" + MID$(t$, 3))
 ELSE
  n& = VAL(t$)
  IF (n& < &H8000) OR (n& > &H7FFF) THEN bomb 7, "Expected: WORD constant literal."
  readword% = VAL(t$)
 END IF
END FUNCTION

SUB section (n AS INTEGER)
 IF n <> currentsection THEN
  SELECT CASE n
  CASE txt: PRINT #1, "section .text"
  CASE dat: PRINT #1, "section .data"
  CASE bss: PRINT #1, "section .bss"
  END SELECT
  currentsection = n
 END IF
END SUB

SUB verifyint (t$)
 IF LEFT$(t$, 2) = "0x" THEN
  FOR i = 3 TO LEN(t$)
   SELECT CASE ASC(LCASE$(MID$(t$, i, 1)))
   CASE &H30 TO &H39, &H61 TO &H66
   CASE ELSE: bomb 0, "Constant literal hex integer contains invalid characters."
   END SELECT
  NEXT i
 ELSE
  FOR i = 1 TO LEN(t$)
   SELECT CASE ASC(MID$(t$, i, 1))
   CASE &H30 TO &H39
   CASE ELSE: bomb 0, "Constant literal dec integer contains invalid characters."
   END SELECT
  NEXT i
 END IF
END SUB

SUB warn (n AS INTEGER)
 PRINT
 IF n THEN
  PRINT "Warning in "; CHR$(&H22); curfil; CHR$(&H22); ", line"; curlin
 ELSE
  PRINT "Warning"
 END IF
 SELECT CASE n
 CASE 0: PRINT "Variable alignment excedes section alignment."
 CASE 1: PRINT "Multidimension array style not specified. Assuming ROWMAJ."
 CASE 2: PRINT "Calling convention not specified. Assuming STDCALL."
 CASE 3: PRINT "Language version mismatch."
 CASE 4: PRINT "Unexpected target."
 CASE 5: PRINT "Local variable alignment excedes stack alignment."
 CASE 6: PRINT "Initiallization value is too small. Zero extending."
 CASE 7: PRINT "Stack size is less than 0x1000 bytes."
 CASE 8: PRINT "Unknown mode."
 CASE 9: PRINT "Unused information is being supplied."
 END SELECT
END SUB

 
 Respond to this message   
 Copyright © 1999-2017 Network54. All rights reserved.   Terms of Use   Privacy Statement  

Newbies usually go to www.qbasic.com and click on The QBasic Forum
Forum regulars have their own ways, which include The QBasic Community Forums