Skip to content

Instantly share code, notes, and snippets.

@pervognsen

pervognsen/tp3.asm

Created June 21, 2020 00:20
Show Gist options
  • Star 7 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save pervognsen/a80aea02793588fcf771857d64ea98c1 to your computer and use it in GitHub Desktop.
Save pervognsen/a80aea02793588fcf771857d64ea98c1 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
tp3.asm
; https://web.archive.org/web/20190701203222/https://www.pcengines.ch/tp3.htm
; The disassembler was applied to a copy of TP 3.01A downloaded from WinWorld.
; I postprocessed the disassembly with a script to clean up spacing and column alignment.
; *** TURBO PASCAL version 3.01 A source code
; ***
; *** commented by Pascal Dornier
; *** all rights reserved
; "***
cseg $100 ; "COM file...
;
; I/O port equates
;
timerfrq= $0042 ; timer: frequency
timercmd= $0043 ; timer: command
timerflg= $0061 ; "PPI: sound enable
;
; interrupt numbers
;
bioscrt = $0010 ; BIOS: CRT driver
bioskbd = $0016 ; BIOS: KBD driver
msdos = $0021 ; "MS-DOS entry
;
; variable definitions
;
attnrm = $0000 ; attribute NormVideo
attlow = $0001 ; attribute LowVideo
att2 = $0002 ; attribute #2 (used by editor)
att3 = $0003 ; attribute #3
txwinx1 = $0004 ; upper left edge current window
txwiny1 = $0005
scrmod = $0006 ; video mode
coltxt = $0007 ; color or text ?
attcur = $0008 ; current attribute
grmod = $0009 ; graphics mode
grwinx1 = $000A ; graphics window: upper left edge
grwinx2 = $000C
grwiny1 = $000E ; bottom right edge
grwiny2 = $0010
delaycnt= $0012 ; number of loop's for 1 ms
collin = $0014 ; line color
lnxdir = $0016 ; X direction
lnydir = $0018 ; Y direction
lnxpos = $001A ; X position
lnypos = $001C ; Y position
lndda = $001E ; DDA register
grback = $0020 ; "graphics: background color
; heap pointer
hpstrt = $0022 ; beginning of heap
hpstrt1 = $0024
hpdstpt = $0026 ; ^ destination pointer
hpdstpt1= $0028
hpesize = $002A ; size of entry to delete
hpesize1= $002C
hplast = $002E ; ^ previous entry
hplast1 = $0030
hpmerg = $0032 ; length of entry to be merged
hpmerg1 = $0034 ; "with next entry
coninbuf= $0036 ; CON input buffer
pnbuf0 = $00B5
pnbuf = $00B6 ; buffer for filename etc.
pnbuf1 = $00B7
pnbuf2 = $00B8
pnbuf3 = $00B9
pndiratt= $00CB ; for Dir: file attribute
pndirnm = $00D4 ; name of file
pndirpad= $00E4 ; ^ end for formatting
pnbufend= $0135 ; "end of buffer
; I/O vectors
vkbdstat= $0136 ; KBD stat (ConStPtr)
vkbdget = $0138 ; KBD get (ConInPtr)
vconput = $013A ; CON put (ConOutPtr)
vprnput = $013C ; PRN put (LstOutPtr)
vauxput = $013E ; AUX put (AuxOutPtr)
vauxget = $0140 ; AUX get (AuxInPtr)
vusrput = $0142 ; USR put (UsrOutPtr)
vusrget = $0144 ; "USR get (UsrInPtr)
; file entries for std files
filcon = $0146 ; CON, TRM
filkbd = $014A ; KBD
fillst = $014E ; LST
filaux = $0152 ; AUX
filusr = $0156 ; USR
stdin = $015A ; MS-DOS input file
stdinfl = $015C ; flag
stdinof = $015E ; ^ buffer
stdinsz = $0160 ; buffer size
stdout = $0166 ; MS-DOS output file
stdoutfl= $0168 ; flag
stdoutof= $016A ; ^ buffer
stdoutsz= $016C ; "buffer size
modeflg = $0172 ; option flag - see initmem
spval = $0174 ; SP on initialisation
turbocs = $0176 ; CS for return to Turbo
turbods = $0178 ; DS for return to Turbo
filtabpt= $017A ; ^ into list of open files
filemax = $017C ; max number of open files
verror = $017E ; ErrorPtr
errnum = $0180 ; error number
conbufln= $0181 ; BufLen (for ReadLn)
conbufpt= $0182 ; ^ into input buffer
conbfend= $0184 ; end of input buffer
errpos = $0186 ; return address ->
errpos2 = $0188 ; position of error
hptop = $018A ; HeapPtr: ^ end of heap
hptop1 = $018C
svintv = $018E ; buffer for vector:
svintv1 = $0190 ; DIV/0 interrupt
lastkey = $0192 ; code of last key pressed
cbreak = $0194 ; CBreak
ovrpnbuf= $0196 ; "buffer for overlay filename
fmtfield= $01E6 ; formatting: field size
fmttype = $01E7 ; type of conversion
fmtsdst = $01E8 ; ^ dest string (STR)
fmtsdst1= $01EA
fmtvdst = $01EC ; ^ dest var (VAL)
fmtvdst1= $01EE
fmtpdst = $01F0 ; ^ error var (VAL)
fmtpdst1= $01F2
recvbuf = $01F4 ; "real buffer: number to convert
errio = $01FA ; flag: return because of error
rndseed = $01FC ; random seed: last random number
rndseed1= $01FE
strdstln= $0200 ; string operations: max. length of result
strpos = $0202 ; Pos
strnum = $0204 ; Num
strtrgt = $0206 ; ^ dest string
strtrgt1= $0208
strobj = $020A ; ^ object string
strobj1 = $020C ; "
remul11 = $020E ; real arithmetics
remul11a= $020F ; first number * /
remul12 = $0210
remul13 = $0212
remul21b= $0213
remul21 = $0214 ; second number * /
remul21a= $0215
remul22 = $0216
remul23 = $0218
retrc1 = $021A ; number for Sqrt, ArcTan, polynomials
retrc2 = $021C
retrc3 = $021E
resign = $0220 ; sign for + -
resave = $0221
remant = $0222 ; mantissa + -
remant1 = $0223 ; "
cvdecexp= $0224 ; real -> ASCII: decimal exponent
cvexpcnt= $0225 ; ASCII -> real: counter for exponent
cvoutbuf= $0226 ; output buffer for result
currfil = $0232 ; ^ current file var
currfil1= $0234
filfunc = $0238 ; function code file operation
filerr = $0239 ; error code, if failure
prnum = $023A ; real: number to print
filetab = $0240 ; "table of open files (file handles)
; kernel variables
freemem = $0260 ; free memory (paragraphs)
stackseg= $0262 ; stack segment on start
stackpt = $0264 ; stack pointer
destseg = $0266 ; segment of compiled program
codesize= $0268 ; code size (paragraphs)
datasize= $026A ; data size (paragraphs)
minstksz= $026C ; min size stack + heap
mincssz = $026E ; min size CS
mindssz = $0270 ; min size DS
minhpsz = $0272 ; min size free heap
maxhpsz = $0274 ; max size free heap
txbeg = $0276 ; ^ beginning of text
txend = $0278 ; ^ end of text
txmemend= $027A ; ^ end of text memory
txerrpos= $027C ; ^ error in text
vfilbig = $027E ; vector: file too big
vnewfil = $0280 ; vector: file not found
txcomp = $0282 ; 0 = text not translated
cpmode = $0283 ; (0 memory, 1 find error, 2 COM, 3 CHN)
cperr = $0284 ; compiler's error number
txchg = $0285 ; 0 = text not changed
defdrv = $0286 ; number of default drive
scrpn = $0287 ; buffer for filename processing
scrpnend= $02C6 ; end of buffer
workpn = $02C7 ; filename work file
mainpn = $0307 ; filename main file
mainflg = $0347 ; 0 = work file used
msgflg = $0348 ; 0 = error messages not read
codedest= $0349 ; (1 = memory, 2 = COM, 3 = CHN)
parmlin = $034A ; buffer: input line for program
knumbuf = $0386 ; number output buffer
curatt = $038E ; "number current video attribute
; editor variables
srend = $0390 ; ^ block end for search
srbeg = $0392 ; ^ block beg for search
bkbeg = $0394 ; ^ block beg
bkend = $0396 ; ^ block end
lnupper = $0398 ; ^ line above
disbeg = $039A ; ^ beginning of text displayed
oldpos = $039C ; old position
eolpos = $039E ; ^ end of line
srpos = $03A0 ; current search pos
srcnt = $03A2 ; search counter
horscr = $03A4 ; horizontal scrolling
attflg = $03A5 ; (1 = block beg, 2 = block end in curr line)
phrow = $03A6 ; cursor position
phcol = $03A7
statobs = $03A8 ; 0 = invalid status line
edcol = $03A9 ; column
attchg = $03AA ; FF = attribute changes in curr line
sropt = $03AB ; options for search
; 1=entire words, 2=replace without query
; 4=upper = lower, 8=global
; 10=backwards 20=L (?)
srmode = $03AC ; 0=search, FF=search and replace
editflg = $03AD ; ? never referenced !
bkhide = $03AE ; FF = invisible block
scrfl1 = $03AF ; FF = short redisplay
statera = $03B0 ; # chars to delete in status line
oldlen = $03B1 ; old length curr line
dislin = $03B2 ; redisplay from line ...
overflg = $03B3 ; 0 = overwrite, FF = insert
indntflg= $03B4 ; 0 = normal, FF = indent
disflg = $03B6 ; FF = don't display
scrfl2 = $03B7 ; redisplay: 0 = small displacement
bkbegl = $03BA ; ^ block beg in curr line
bkendl = $03BC ; ^ block end in curr line
edpos = $03BE ; ^ current line
lnpos = $03C0 ; pos in line buffer
posfifo = $03C2 ; old position for ^QP
pfifosrc= $03C5
qppos = $03C6
qppos1 = $03C8
pfifodst= $03C9 ; (for block transfer)
cmdbuf = $03CA ; buffer for command entry
cmdbuf1 = $03CB
srword = $03CE ; max length of search word
srword1 = $03CF ; length
srword2 = $03D0 ; string
srrepl = $03EF ; replace word
srrepl1 = $03F0
srrepl2 = $03F1
stopt = $0410 ; options for search / replace
sropt1 = $0411
fnbuf = $041D ; buffer for filename entry
fnbuf2 = $041F
fnbufend= $0460
nbkbeg = $0461 ; block transfer destination
nbk = $0463 ; block
sepptr = $0465 ; ^ word separator table
explen = $0467 ; expected length
curpast = $0469 ; 1 = cursor past end of line
line0 = $046B
line = $046C ; buffer: current line
lineend0= $04E9
lineend1= $04EA
lineend = $04EB
dmabuf = $04EE ; buffer for redisplay
scrseg = $0590 ; segment of video memory
scrrow = $0592 ; video row
scrbad = $0593 ; "FF = snowy screen
; compiler variables
spsav = $0594 ; SP at start
symtop = $0596 ; current end of symbol table
symtop2 = $0598 ; end of symbol table
ptcbeg = $059A ; ^ beg symbol table, patch list
tyfence = $059C ; limit for undefined pointer types
fence = $059E ; limit for search on new definition
pc = $05A0 ; PC of emitted code
dc = $05A2 ; data offset of emitted code
varspc = $05A4 ; space used on stack
cdptr = $05A6 ; ^ into code buffer
cdbufpt = $05A8 ; PC of beg code buffer
cdbegpt = $05AA ; ^ code buffer
cdfoff = $05AC ; buffer's offset in file
cdprcoff= $05AD ; offset for overlay
cdfoff1 = $05AE
lincnt = $05B0 ; line counter
cdinval = $05B2 ; <> 0: invalid code
recnum = $05B3 ; number of current record
reccnt = $05B4 ; record counter
scalcnt = $05B5 ; enumeration type counter
srcend = $05B6 ; <> 0: end of source reached
lexnest = $05B7 ; lexical nesting
flgpshax= $05B8 ; <> 0: save AX on stack
flgpshes= $05B9 ; <> 0: save ES on stack
flgpshdi= $05BA ; <> 0: save DI on stack
usrint = $05BB ; <> 0: user interrupt used
ovrcnt = $05BC ; overlay counter
inclflg = $05BD ; FF = include file used
cmaxfil = $05BF ; max number of open files
cinpsize= $05C1 ; size of std input buffer
coutsize= $05C3 ; size of std output buffer
direct = $05C5 ; compiler directives:
; 1 = I/O check
; 2 = range check
; 4 = I/O mode (CON or TRM)
; 8 = value for CBreak
; 10 = user interrupt
; 20 = stack check
; 40 = type check
; 80 = device check
destpn = $05C7 ; object filename
destpne = $0603
dstfile = $0607 ; object file handle
ptctop = $0609 ; current end of patch list
ptcend = $060B ; limit for patch list
srcptr = $060D ; ^ into text
srclnbeg= $060F ; ^ beg of source line
chptr = $0611 ; ^ into line buffer
; variable entry 1:
indflg = $0615 ; <> 0: indexed var
indptflg= $0616 ; <> 0: indirect via pointer
varseg = $0617 ; segment (FF=DS, FE=CS, FD=ES, else:
; lexical nesting
varofs = $0618 ; variable offset
vartp = $061A ; type
varctp = $061C ; element type
varnest = $061D ; <>0: record #, FF: undef pointer
lower = $061E ; lower bound or ^ index type
upper = $0620 ; upper bound or ^ element type
varsize = $0622 ; variable size
parm1end= $0624
parm2 = $0625 ; variable entry 2
var2ctp = $062C ; type
lower2 = $062E ; lower bound
upper2 = $0630 ; upper bound
var2size= $0632 ; size
maxsize = $0634 ; max size for variant records
uncrlink= $0636 ; link for uncrunch list
flgvar = $0638 ; F = VAR parameter
vrecflg = $0639 ; number of record variant
procfnc = $063A ; procedure or function
ovrproc = $063B ; <>0: overlay procedure
absflg = $0647 ; FF = Absolute variable
var3ofs = $0648 ; offset
var3seg = $064A ; segment
ovrlen = $064C ; max length of overlay procedures in a file
creal1 = $064E ; buffer for real constant
creal2 = $0650
creal3 = $0652
cresign = $0653
stklev = $0654 ; stack use (WITH, FOR, display)
casectp = $0655 ; CASE element type
direcsv = $0656 ; directives at beg of statement
brnchop = $0658 ; branch op on comparision
rdlnflg = $0659 ; flag: Read / ReadLn
forptr = $065A ; pointer for FOR: TO / DOWNTO
withnest= $065C ; WITH nesting
inlinflg= $065D ; inline flag
withtab = $065E ; WITH table: record number, segment
withtab1= $0660 ; offset, FFFF = indexed
functp = $069E ; ^ result type
comptp = $06A0 ; ^ type for comparison
oldpc = $06A2 ; PC before translation of this atom
negflg = $06A4 ; negation flag
exres = $06A6 ; integer constant
cxbuf = $06A8 ; buffer for CX
direcin = $06AA ; directives before include
semiflg = $06AC ; flag for missing error
wordflg = $06AD ; type of word read
typept = $06AE ; ^ type
sympos = $06B0 ; ^ into symbol table
wrdend = $06B2 ; end of word read
retbuf = $06B4 ; buffer for return address
inclpn = $06B6 ; include filename
incfile = $06F6 ; include file handle
bufpt = $06F8 ; include pointer
bufend = $06FA ; end of include buffer
srclnbg = $06FC ; beg of line in buffer
frelpos = $06FE ; relative position in file
ptcbuf1 = $0700 ; buffer for patch
wordbuf = $0702 ; buffer for word, filename, string...
wrdbuf1 = $0703
inclbuf = $0782 ; include buffer
txstrt = $0802 ; "beg of text space / error messages
JMP start ; "jump to main code
B $90,$90,$CD,$AB
B "Copyright (C) 1985 BORLAND Inc"
B $02,$04,$00
W ecmd1 ; ptrs for TINST.COM
B $00
W errpath
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
displstrB $14,"Default display mod"
B $65
txwinx2 B $50 ; lower edge of text window
txwiny2 B $19
B $01,$FF,$FF
attmono B $0F,$07,$07,$70 ; monochrome attributes
attbwgr B $0F,$07,$07,$70 ; mono graphic atts
attcolgrB $0E,$07,$07,$4F ; "color graphic atts
putstr CS: ; put attribute string
MOV.B AH,[BX] ; length
OR.B AH,AH
STC
JZ puts2 ; nothing to put
putstrl INC BX ; next char
CS:
MOV.B AL,[BX] ; get it
PUSH AX ; save cnt
CALL conput ; put CRT
POP AX
DEC.B AH ; another one ?
JNZ putstrl ; :yes
CLC
puts2 RET ; "
meascnt W $0000
measdoneB $00
vtimer W $0000 ; "space for timer int vector
vtimer1 W $0000
msspeed MOV delaycnt,#$006E ; measure CPU speed
CS: ; measurement value
MOV.B measdone,#$00 ; flag:not done
MOV SI,#timvec ; ptr to timer INT
ES:
MOV AX,[SI]
CS:
MOV vtimer,AX ; save it
ES:
MOV AX,[SI]$02
CS:
MOV vtimer1,AX
CLI
ES:
MOV [SI],#msint1
ES:
MOV [SI]$02,CS
STI ; INT ok again
JMP.b mssploop ; "measurement loop
msint1 PUSH DS ; first INT entry
PUSH AX
XOR AX,AX
MOV DS,AX
MOV timvec,#msint2 ; set second vector
CS:
MOV meascnt,AX ; clear counter
POP AX
POP DS
CS:
JMPF [vtimer] ; "do timer routine
msint2 CS: ; second INT entry
MOV.B measdone,#$FF ; set flag:done
CS:
JMPF [vtimer] ; "do timer routine
mssploopCALL delay1ms ; wait one step
CS:
INC meascnt ; count those steps
CS:
CMP.B measdone,#$FF ; done ?
JNZ mssploop ; no, continue counting
CS:
MOV AX,vtimer1 ; restore timer INT vec
CLI
ES:
MOV [SI]$02,AX
CS:
MOV AX,vtimer
ES:
MOV [SI],AX
STI ; INT ok again
CS:
MOV AX,meascnt ; number of steps done
ADD AX,AX ; *2
MOV delaycnt,AX ; -> result
RET ; "
delaybx MOV AX,BX ; Delay(BX)
xdelay MOV CX,AX ; DELAY(AX)
JCXZ delay2 ; :no delay
delay1 CALL delay1ms ; delay 1ms
LOOP delay1
delay2 RET ; "
delay1msPUSH CX ; Delay 1 ms
MOV CX,delaycnt ; get count for 1ms
delay3 LOOP delay3 ; do it
POP CX ; restore cnt
RET ; "
xclrscr PUSH BP ; CLRSCR
MOV AH,#$0F ; get screen stat
INT bioscrt
POP BP
CMP.B AL,scrmod ; = current screen mode ?
JZ clrscr1 ; :ok
MOV AL,scrmod ; no: do set it
JMP xtxtmode ; '
clrscr1 PUSH BP
MOV AX,#$0600 ; scroll window up, 0 lines
MOV.B BH,attcur
MOV CX,txwinx1 ; upper left edge
CS:
MOV DX,txwinx2 ; lower right edge
DEC.B DH
DEC.B DL
INT bioscrt ; clear window
MOV AH,#$02 ; set cursor position
MOV DX,txwinx1 ; upper left edge
XOR.B BH,BH
INT bioscrt ; do it
POP BP
RET ; "
xdellinePUSH BX ; DelLine
PUSH CX
PUSH DX
PUSH BP
CALL getcpos ; get cursor pos
MOV AH,#$06 ; scroll window up
doscrollMOV AL,#$01 ; one line
MOV.B BH,attcur
MOV.B CH,DH
MOV.B CL,txwinx1 ; upper left edge
CS:
MOV DX,txwinx2 ; lower right of window
DEC.B DH
DEC.B DL
CMP.B CH,DH ; same ?
JNZ dellin1 ; :no
XOR.B AL,AL ; no lines
dellin1 INT bioscrt ; do it
POP BP
POP DX
POP CX
POP BX
RET ; "
xinslinePUSH BX ; InsLine
insline2PUSH CX
PUSH DX
PUSH BP
CALL getcpos ; get cursor pos
MOV AH,#$07 ; scroll window down
JMP doscroll ; "as above
xlowvid PUSH AX ; LowVideo
MOV AL,attlow ; set low attribute
MOV attcur,AL
POP AX
RET ; "
xnormvidPUSH AX ; NormVideo, HighVideo
MOV AL,attnrm ; set normal attribute
MOV attcur,AL
POP AX
RET ; "
getcpos MOV AH,#$03 ; get cursor position
XOR.B BH,BH ; page 0
INT bioscrt ; do it
RET ; "
xclreol PUSH BX ; ClrEol
PUSH CX
PUSH DX
PUSH BP
CALL getcpos ; get cursor pos
MOV AX,#$0600 ; clear window
MOV.B BH,attcur
MOV CX,DX ; pos -> upper left
CS:
MOV.B DL,txwinx2 ; X-position
DEC.B DL ; Y-pos from current pos
INT bioscrt ; do it
POP BP
POP DX
POP CX
POP BX
RET ; "
xcrtinitCALL xnosound ; CrtInit
CS: ; Screen mode
MOV AL,scrmodch ; defined with TINST
CMP AL,#$FF
JNZ xtxtmode ; do change it
PUSH BP
MOV AH,#$0F ; get current screen mode
INT bioscrt
POP BP
xtxtmodeMOV.B txwinx1,#$00 ; TextMode
MOV.B txwiny1,#$00 ; set window
MOV.B grmod,#$FF ; no graphics mode
CMP AL,#$07 ; monochrome ?
MOV BH,#$50
MOV BL,#$00
MOV SI,#attmono ; ptr to screen attributes
JZ txtmd3 ; :yes, mono
MOV SI,#attcolgr
CMP AL,#$02 ; BW80 ?
JZ txtmd2 ; :yes
CMP AL,#$04
JB txtmd1 ; :C80, C40, BW40
MOV AL,#$03
txtmd1 MOV BL,#$FF
CMP AL,#$03 ; C80 ?
JZ txtmd3 ; :yes
MOV BH,#$28
CMP AL,#$01 ; C40 ?
JZ txtmd3 ; :yes
XOR.B AL,AL ; monochrome
MOV BL,#$00
txtmd2 MOV SI,#attbwgr
txtmd3 MOV scrmod,AL ; set screen mode
MOV.B coltxt,BL ; color or mono
CS:
MOV.B txwinx2,BH ; set screen size
CS:
MOV AX,[SI] ; get screen attributes
MOV attnrm,AX
CS:
MOV AX,[SI]$02
MOV att2,AX
PUSH BP
MOV AH,#$0F ; get screen status
INT bioscrt
CMP.B AL,scrmod ; correct mode ?
JZ txtmd4 ; :yes
MOV AL,scrmod
XOR.B AH,AH ; set screen mode
INT bioscrt
txtmd4 POP BP
JMP xnormvid ; "
xcrtexitRET ; "CrtExit
setcpos PUSH AX ; Set cursor position
PUSH BX ; DL=row
PUSH CX ; DH=col
PUSH DX ; pos relative to curr window
PUSH SI
PUSH DI
PUSH BP
PUSHF
XCHG.B DL,DH
ADD DX,txwinx1 ; add window pos
CS:
CMP.B DH,txwiny2 ; over edge of screen ?
JNB setcbad ; :yes
CS:
CMP.B DL,txwinx2
JNB setcbad ; :yes
MOV AH,#$02 ; set cursor
XOR.B BH,BH ; page 0
INT bioscrt
setcbad POPF
POP BP
POP DI
POP SI
POP DX
POP CX
POP BX
POP AX
RET ; "
xupcase JMP upcase ; "UpCase
xwherex CALL getcpos ; WhereX
MOV.B AL,DL ; get cursor pos
SUB.B AL,txwinx1 ; col-window col
INC.B AL ; +1
XOR.B AH,AH
RET ; "
xwherey CALL getcpos ; WhereY
MOV.B AL,DH ; get cursor pos
SUB.B AL,txwiny1 ; row-window row
INC.B AL ; +1
XOR.B AH,AH
RET ; "
xwindow POP BX ; Window
CMP AL,#$19 ; Row 2 - limit to 25
JA window1 ; :too much
CS:
MOV txwiny2,AL ; set it
window1 POP AX ; Col 2
CMP AL,#$50 ; limit to 80
JA window2 ; :too much
CS:
MOV txwinx2,AL ; set it
window2 POP AX ; Row 1
CS:
CMP.B AL,txwiny2 ; > row 2 ?
JNB window3 ; : no good
DEC.B AL
MOV txwiny1,AL ; set it
window3 POP AX ; Col 1
CS:
CMP.B AL,txwinx2 ; > col 2
JNB window4 ; :no good
DEC.B AL
MOV txwinx1,AL ; set it
window4 JMP BX ; "return
xtxtcol AND AL,#$1F ; TextColor
TEST AL,#$10 ; Blink ?
JZ txtcol1 ; :no
AND AL,#$0F
OR AL,#$80 ; set blink flag
txtcol1 AND.B attcur,#$70
OR.B attcur,AL ; set new attribute
RET ; "
xtxtbg AND AL,#$07 ; TextBackground
MOV CL,#$04
SHL.B AL,CL
AND.B attcur,#$8F
OR.B attcur,AL ; set attribute
RET ; "
setgmod PUSH BP ; Set graphic mode
MOV grwinx2,AX ; X-size
MOV grwinx1,#$0000 ; clear window
MOV grwiny1,#$0000
MOV grwiny2,#$00C7 ; Y-size = 199
MOV AL,grmod
XOR.B AH,AH
INT bioscrt ; set graph mode
XOR BX,BX
MOV.B grback,BL ; clear background
MOV AH,#$0B ; set palette -> backgrnd
INT bioscrt
INC.B BH ; set foregrnd
MOV AH,#$0B
INT bioscrt ; set palette
POP BP
RET ; "
xgrcolmdMOV.B grmod,#$04 ; GraphColorMode
setgmod2MOV AX,#$013F ; X-size = 319
JMP setgmod ; 'set it
xgrmode MOV.B grmod,#$05 ; GraphMode
JMP setgmod2 ; "set it
xhires MOV.B grmod,#$06 ; Hires
MOV AX,#$027F ; X-size = 639
CALL setgmod ; set it
MOV AX,#$000F ; set background
JMP.b xhirscol ; "
xgrbg AND AL,#$0F ; GraphBackground
MOV.B AH,grback ; get old color
AND.B AH,#$10
OR.B AL,AH
MOV grback,AL ; store it
setbg PUSH BP ; set graph background
XOR.B BH,BH
MOV.B BL,grback
MOV AH,#$0B ; set palette
INT bioscrt ; do it
POP BP
RET ; "
xpalettePUSH BP ; set palette AL
MOV.B BL,grback ; get current color
AND.B BL,#$EF ; clear palette
MOV AH,#$02
CMP.B grmod,#$04 ; color graphics ?
JZ setpal1 ; yes
MOV AH,#$01
setpal1 CMP.B AL,AH
JB setpal2
SUB.B AL,AH ; upper bit: part of backgnd
OR.B BL,#$10
setpal2 MOV.B grback,BL ; set it
MOV BH,#$01 ; set palette
MOV.B BL,AL ; palette number
MOV AH,#$0B
INT bioscrt ; do it
POP BP
JMP setbg ; "set backgnd color
xhirscolPUSH BP ; HiresColor
MOV BX,AX ; as background
MOV AH,#$0B ; set palette
INT bioscrt ; do it
POP BP
RET ; "
xgrwindwPOP BX ; GraphWindow
MOV CX,#$027F ; max. X = 639
CMP.B grmod,#$06 ; Hires ?
JZ gwind1 ; :yes
MOV CX,#$013F ; max. X = 319
gwind1 CMP AX,#$00C7 ; Y2 > 199
JA gwind2 ; :no good
MOV grwiny2,AX ; set Y2
gwind2 POP AX ; X2
CMP AX,CX ; > max X ?
JA gwind3 ; :no good
MOV grwinx2,AX ; set X2
gwind3 POP AX ; Y1
CMP AX,grwiny2 ; >= Y2 ?
JNB gwind4 ; :no good
MOV grwiny1,AX ; set Y1
gwind4 POP AX ; X1
CMP AX,grwinx2 ; >= X2 ?
JNB gwind5 ; :no good
MOV grwinx1,AX ; set X1
gwind5 JMP BX ; "return
xplot POP BX ; Plot
POP DX ; Y-pos
POP CX ; X-pos
PUSH BX ; restore return addr
MOV AH,#$0C ; set point, AL is color
doplot OR CX,CX ; test X-pos (do clipping)
JS noplot ; negative: clip it
ADD CX,grwinx1 ; add window offset
CMP CX,grwinx2 ; outside window ?
JA noplot ; yes: clip it
OR DX,DX ; test Y-pos
JS noplot ; negative: clip it
ADD DX,grwiny1 ; add window offset
CMP DX,grwiny2 ; outside window ?
JA noplot ; yes: clip it
PUSH BP
INT bioscrt ; do plot
POP BP
noplot RET ; "
xdraw MOV AH,#$0C ; Line. AL is color
MOV collin,AX ; set color, command:plot
POP DI ; return addr
POP AX ; Y2
POP DX ; X2
POP BX ; Y1
MOV lnypos,BX ; store it
CALL getdelta ; calculate direction
MOV lnydir,CX ; store it
CALL iabs ; ABS(AX)
XCHG AX,DX ; DX:=Y-distance YD
POP BX ; X1
PUSH DI ; restore ret addr
MOV lnxpos,BX ; store X1
CALL getdelta ; calculate direction
MOV lnxdir,CX ; store it
CALL iabs ; ABS(AX)
MOV BX,AX ; BX:=X-distance XD
CMP BX,DX ; XD <= YD ?
JLE lnyline ; yes:Y-oriented line
MOV AX,DX ; X-oriented line
ADD AX,AX
SUB AX,BX
MOV lndda,AX ; DDA:=YD+YD-XD
MOV CX,BX ; XD -> count
INC CX
lnxloop CALL lnplot ; plot point with clipping
MOV AX,lndda ; test DDA
OR AX,AX
JLE lnxnostp ; :no step
ADD AX,DX ; DDA:=DDA+YD+YD-XD-XD
ADD AX,DX
SUB AX,BX
SUB AX,BX
MOV lndda,AX
MOV AX,lnydir ; Ypos:=Ypos+Ydir
ADD lnypos,AX
JMP.b lnxcont ; '
lnxnostpADD AX,DX ; DDA:=DDA+YD+YD
ADD AX,DX
MOV lndda,AX
lnxcont MOV AX,lnxdir ; Xpos:=Xpos+Xdir
ADD lnxpos,AX
LOOP lnxloop ; another step
RET ; '
lnyline MOV AX,BX ; Y-oriented line
ADD AX,AX
SUB AX,DX
MOV lndda,AX ; DDA:=XD+XD-YD
MOV CX,DX ; YD -> count
INC CX
lnyloop CALL lnplot ; plot point with clipping
MOV AX,lndda ; test DDA
OR AX,AX
JLE lnynostp ; :no step
ADD AX,BX ; DDA:=DDA+XD+XD-YD-YD
ADD AX,BX
SUB AX,DX
SUB AX,DX
MOV lndda,AX
MOV AX,lnxdir ; Xpos:=Xpos+Xdir
ADD lnxpos,AX
JMP.b lnycont ; '
lnynostpADD AX,BX ; DDA:=DDA+XD+XD
ADD AX,BX
MOV lndda,AX
lnycont MOV AX,lnydir ; Ypos:=Ypos+Ydir
ADD lnypos,AX
LOOP lnyloop ; :another one
RET ; "
getdeltaXOR CX,CX ; calculate direction -> CX
SUB AX,BX ; compare them
JZ deltazer ; equal: CX=0
JS deltaneg ; :negative
INC CX ; positive: CX=1
RET ; '
deltanegDEC CX ; negative: CX=-1
deltazerRET ; "
lnplot PUSH CX ; Set line point with clipping
PUSH DX ; save count, YD
MOV AX,collin ; color, command
MOV CX,lnxpos ; Xpos
MOV DX,lnypos ; Ypos
CALL doplot ; plot that point
POP DX
POP CX
RET ; "
xsound MOV BX,AX ; Sound
MOV AX,#$34DD ; for frequency calculation
MOV DX,#$0012
CMP DX,BX ; frequency < 12 Hz ?
JNB sounddis ; :might damage speaker
DIV BX ; calculate timer value
MOV BX,AX
IN AL,timerflg ; sound on ?
TEST AL,#$03
JNZ soundon ; :yes
OR AL,#$03 ; switch it on
OUT timerflg,AL
MOV AL,#$B6 ; set frequency
OUT timercmd,AL
soundon MOV.B AL,BL ; set freq lo
OUT timerfrq,AL
MOV.B AL,BH ; set freq hi
OUT timerfrq,AL
sounddisRET ; "
xnosoundIN AL,timerflg ; NoSound
AND AL,#$FC ; switch it off
OUT timerflg,AL
RET ; "
xgetmem XCHG AX,CX ; GetMem, AX=length requested
POP BX ; ret addr
POP DI ; dest ptr
JMP.b new1 ; "like New
hpconv PUSH AX ; change representation:
PUSH CX ; AX=ofs 0..15, BX=seg
MOV CL,#$04
SHR AX,CL
ADD BX,AX ; seg:=seg+ofs DIV 16
POP CX
POP AX
AND AX,#$000F ; ofs:=ofs MOD 16
RET ; "
hpcmp CMP BX,DX ; Compare BX:AX with DX:CX
JNZ hpcmp1
CMP AX,CX
hpcmp1 RET ; "
hpadd ADD AX,CX ; BX:AX + DX:CX -> BX:AX
ADD BX,DX
JMP hpconv ; "change representation
hplen ES: ; Get length of entry
MOV AX,[DI]$04
ES:
MOV BX,[DI]$06
PUSH AX
OR AX,BX ; test if end of heap = 0
POP AX
RET ; "
xnew POP BX ; New
new1 POP ES ; dest ptr
PUSH BX ; restore ret
MOV hpdstpt,DI ; save addr dest ptr
MOV hpdstpt1,ES
MOV AX,CX ; number of bytes wanted
ADD AX,#$0007 ; +7
MOV BX,#$1000 ; carry ?
JB new2 ; :yes
XOR BX,BX ; no carry
new2 AND AL,#$F8 ; space allocated is n*8
CALL hpconv ; convert to seg,ofs
MOV CX,AX ; needed size
MOV DX,BX
MOV hplast,#$0022 ; last entry
MOV hplast1,DS
LES DI,hpstrt ; get start of heap
newseek CALL hplen ; get len of entry
JZ newend ; :end of heap
CALL hpcmp ; sufficient size ?
JNB newfnd ; :large enough
MOV hplast,DI ; remember last entry
MOV hplast1,ES
ES: ; get next entry
LES DI,[DI]
JMP newseek ; 'continue searching
newfnd CALL newdest ; store ES:DI to dest ptr
JZ newfits ; equal - nothing to crunch
SUB AX,CX ; calculate superfluous mem
SBB BX,DX
AND AX,#$000F
JMP.b newrem ; 'mark the remainder as free
newfits ES: ; get next entry
LES DI,[DI]
JMP.b newlink ; 'set link to it
newend CALL newdest
MOV AX,DI
MOV BX,ES
CALL hpadd ; sum up sizes
MOV hptop,AX ; new heap top
MOV hptop1,BX
PUSH CX ; save size of entry
PUSH DX
MOV CX,AX ; test if heap overflow
MOV DX,BX
MOV AX,SP ; heap top - stack top
MOV BX,SS
SUB BX,#$0E
CALL hpconv ; convert sp
XOR AX,AX
CALL hpcmp ; compare them
POP DX
POP CX
JA newmemok ; :ok
JMP chkstk1 ; 'Error FF - memory overflow
newmemokXOR AX,AX ; mark next entry
XOR BX,BX ; as end of heap
newrem PUSH BX ; save length
PUSH AX
ES: ; save ptr to next entry
PUSH [DI]$02
ES:
PUSH [DI]
MOV AX,DI ; try to put together with
MOV BX,ES ; next entry
CALL hpadd ; calc end of this entry
MOV DI,AX ; new top
MOV ES,BX
ES: ; now produce that entry
POP [DI] ; link
ES:
POP [DI]$02
ES:
POP [DI]$04 ; length
ES:
POP [DI]$06
newlink PUSH ES ; save ES
PUSH ES
LES SI,hplast ; store ES:DI in last
ES: ; entry as link to next entry
MOV [SI],DI
ES:
POP [SI]$02
POP ES ; restore ES
RET ; "
newdest PUSH ES ; store ES:DI in dest ptr
PUSH ES
LES SI,hpdstpt
ES:
MOV [SI],DI
ES:
POP [SI]$02
POP ES
RET ; "
xfreememXCHG AX,CX ; FreeMem
POP BX ; ret addr
POP DI ; get ptr
JMP.b disp1 ; 'like Dispose
xdisposePOP BX ; Dispose
disp1 POP ES ; get dest ptr
PUSH BX ; restore ret
MOV AX,CX ; number of bytes
ES:
MOV CX,[DI] ; get value of ptr
ES:
MOV DX,[DI]$02
ADD AX,#$0007 ; size+7
MOV BX,#$1000 ; carry ?
JB disp2 ; :yes
XOR BX,BX ; no carry
disp2 AND AL,#$F8
CALL hpconv
MOV hpesize,AX ; save size of
MOV hpesize1,BX ; entry to erase
LES DI,hpstrt ; start at the beginning
MOV AX,DI
MOV BX,ES
CALL hpcmp ; = entry to erase ?
JNB dispdel ; :no free space before
dispseekES: ; get link
MOV AX,[DI]
ES:
MOV BX,[DI]$02
CALL hpcmp ; compare with our entry
JNB dispfnd
MOV DI,AX ; go to next entry
MOV ES,BX
JMP dispseek ; 'continue
dispfnd PUSH ES ; ES:DI last entry
MOV SI,CX ; DX:CX searched one
MOV ES,DX ; AX:BX current entry
PUSH hpesize1
PUSH hpesize
ES: ; store link in disposed entry
MOV [SI],AX
ES:
MOV [SI]$02,BX
ES: ; store length
POP [SI]$04
ES:
POP [SI]$06
POP ES ; restore ES
ES:
MOV [DI],CX ; store addr in last entry
ES:
MOV [DI]$02,DX
ES:
MOV AX,[DI]$04 ; get length of this entry
ES:
MOV BX,[DI]$06
CALL dispmerg ; try to put them together
JZ dispdone ; :end of heap
ES: ; get addr of next one
LES DI,[DI]
dispdoneES: ; get length of this entry
MOV AX,[DI]$04
ES:
MOV BX,[DI]$06
ES: ; get link of this entry
MOV CX,[DI]
ES:
MOV DX,[DI]$02
JMP.b dispmerg ; 'try to put them together
dispdel MOV hpstrt,CX ; link to next entry
MOV hpstrt1,DX
MOV DI,CX ; ptr to this entry
MOV ES,DX
ES: ; store link to next one
MOV [DI],AX
ES:
MOV [DI]$02,BX
MOV CX,AX ; link for collect
MOV DX,BX
MOV AX,hpesize ; store its len
MOV BX,hpesize1
ES:
MOV [DI]$04,AX
ES:
MOV [DI]$06,BX
; try to merge contiguous entries - thus reducing
; fragmentation of the heap.
dispmergMOV hpmerg,AX ; length of this entry
MOV hpmerg1,BX
ADD AX,DI ; + its address
MOV BX,ES
ADD BX,hpmerg1
CALL hpconv ; convert
CALL hpcmp ; = next entry ?
JNZ disprt ; no:cannot put them together
MOV AX,hptop ; = heap top ?
MOV BX,hptop1
CALL hpcmp
JZ disptop ; yes:set new, lower heap top
PUSH ES ; save ES
MOV SI,CX ; addr of next entry
MOV ES,DX
ES: ; get link to next entry
MOV AX,[SI]
ES:
MOV BX,[SI]$02
ES: ; get length
MOV CX,[SI]$04
ES:
MOV DX,[SI]$06
POP ES ; restore ES
ES: ; store link
MOV [DI],AX
ES:
MOV [DI]$02,BX
MOV AX,hpmerg ; get length
MOV BX,hpmerg1
CALL hpadd ; add them
ES: ; store new length
MOV [DI]$04,AX
ES:
MOV [DI]$06,BX
XOR AX,AX
RET ; '
disptop MOV hptop,DI ; set new heap top
MOV hptop1,ES
PUSH DI ; clear 8 bytes
XOR AX,AX ; = marker for end of heap
CLD
MOV CX,#$0004
REPZ
STOS
POP DI ; restore
XOR AX,AX
disprt RET ; "
xmemavl XOR CX,CX ; MemAvail
XOR DX,DX ; clear sum
XOR SI,SI
LES DI,hpstrt ; get heap start
memav1 CALL hplen ; get length
JZ memav2 ; :end of heap
CALL hpaddcmp ; sum it up, test size
ES: ; get next entry
LES DI,[DI]
JMP memav1 ; 'continue
memav2 MOV AX,SP ; last entry: free space
MOV BX,SS ; between stack and heap
SUB BX,#$10 ; leave some space
CALL hpconv ; convert
XOR AX,AX ; clear offset
SUB BX,hptop1 ; subtract heap top
JB memav3 ; :nothing left
CALL hpaddcmp ; sum it up
memav3 MOV AX,DX ; space left (paragraphs)
RET ; "
hpaddcmpCMP SI,BX ; is it the largest one ?
JNB hpac2 ; :no
MOV SI,BX ; yes, remember its size
hpac2 CALL hpadd ; sum it up
MOV CX,AX ; remember sum
MOV DX,BX
RET ; "
xmaxavl CALL xmemavl ; MaxAvail: do MemAvail
MOV AX,SI ; get largest size
RET ; "
xmark POP BX ; Mark
POP ES ; get ptr
MOV AX,hptop ; Heap top -> ptr
ES:
MOV [DI],AX
MOV DX,hptop1
ES:
MOV [DI]$02,DX
JMP BX ; "return
xreleasePOP BX ; Release
POP ES ; ptr addr
ES: ; get pointer
LES DI,[DI]
MOV hptop,DI ; -> heap top
MOV hpstrt,DI ; -> heap start
MOV hptop1,ES
MOV hpstrt1,ES
XOR AX,AX ; clear 8 bytes in entry
LES DI,hpstrt ; = marker for end of heap
MOV CX,#$0004
CLD
REPZ
STOS
JMP BX ; "return
kbdstat CMP.B lastkey,#$00 ; Get key stat
MOV AL,#$FF ; something there ?
JNZ kbdst2 ; :true
MOV AH,#$01 ; test kbd stat
INT bioskbd
MOV AL,#$00 ; false
JZ kbdst2 ; :nothing available
DEC.B AL ; true
kbdst2 AND AX,#$0001
RET $0001 ; "
kbdget MOV AL,lastkey ; Get KBD char
MOV.B lastkey,#$00 ; clear last key code
OR.B AL,AL
JNZ kbdg3 ; :was full - take it
XOR.B AH,AH ; get key
INT bioskbd
OR.B AL,AL ; test it
JNZ kbdg2 ; :normal char
MOV.B lastkey,AH ; store scan code
MOV AL,#$1B ; return ESC
OR.B AH,AH
JNZ kbdg3
MOV AL,#$03 ; Break !
kbdg2 CMP.B cbreak,#$01 ; Break allowed ?
JNZ kbdg3 ; :no
CMP AL,#$03 ; Break ?
JNZ kbdg3 ; :no
JMP brkmsg ; '
kbdg3 XOR.B AH,AH ; clear hi byte
RET $0001 ; "
crtput POP AX ; Print char to screen
POP DX ; char to be printed
PUSH AX ; restore ret
PUSH DX ; save regs
PUSH BP
PUSH DX
CALL getcpos ; get cursor pos
POP AX ; char to be printed
CMP AL,#$0D ; Carriage Return ?
JNZ crtlf ; :no
MOV.B DL,txwinx1 ; go to left margin
JMP.b crtsetps ; 'set new pos
crtlf CMP AL,#$0A ; Line Feed ?
JNZ crtbs ; :no
INC.B DH ; add 1 to line
CS:
CMP.B DH,txwiny2 ; >= bottom ?
JB crtsetps ; :no, set pos
JMP.b crtscrol ; 'scroll up
crtbs CMP AL,#$08 ; Backspace ?
JNZ crtbell ; :no
CMP.B DL,txwinx1 ; at the left ?
JZ crtsetps ; yes, no change
DEC.B DL ; go back
JMP.b crtsetps ; 'set cursor pos
crtbell CMP AL,#$07 ; Bell ?
JNZ crtchar ; :no
MOV AH,#$0E ; write char
XOR.B BH,BH
INT bioscrt
JMP.b crttest ; 'no pos change
crtchar PUSH DX ; remember position - put char
MOV AH,#$09 ; write char
XOR.B BH,BH ; screen page 0
MOV CX,#$0001 ; 1 char
MOV.B BL,attcur ; current attribute
INT bioscrt ; do it
POP DX ; restore pos
INC.B DL ; go right one char
CS:
CMP.B DL,txwinx2 ; = right margin ?
JB crtsetps ; :no, set new pos
MOV.B DL,txwinx1 ; go to the left
INC.B DH ; next line
CS:
CMP.B DH,txwiny2 ; = bottom ?
JB crtsetps ; no: set pos
crtscrolDEC.B DH ; scroll up
PUSH DX ; save pos
MOV AX,#$0601 ; scroll up one line
MOV.B BH,attcur ; att for empty line
MOV CX,txwinx1 ; position upper left
CS:
MOV DX,txwinx2 ; position lower right
DEC.B DH
DEC.B DL
INT bioscrt ; do it
POP DX
crtsetpsMOV AH,#$02 ; set cursor pos
XOR.B BH,BH ; screen 0
INT bioscrt ; do it
crttest POP BP
CMP.B cbreak,#$01 ; test for break ?
JNZ crtnobrk ; :no
DEC SP
CALL kbdstat ; get key stat
JZ crtnobrk ; :nothing
DEC SP
CALL kbdget ; get key
CMP AL,#$13 ; ^S ?
JNZ crtnobrk ; :no
DEC SP
CALL kbdget ; get key
crtnobrkPOP AX ; restore char
RET ; "
lstput POP AX ; put to LST
POP DX ; get char
PUSH AX ; restore ret
MOV AH,#$05 ; operation
JMP.b dos ; 'do MS-DOS
NOP ; Courtesy of LINK
auxput POP AX ; put to AUX
POP DX ; get char
PUSH AX ; restore ret
MOV AH,#$04 ; operation
JMP.b dos ; 'do MS-DOS
NOP
auxget MOV AH,#$03 ; Get from AUX
CALL dos ; do MS-DOS
XOR.B AH,AH ; clear hi byte
RET $0001 ; '
dos CMP.B AH,#$3D ; do MS-DOS-operation
JZ openfil ; :Open file
CMP.B AH,#$3C
JZ openfil ; :Create file
CMP.B AH,#$3E
JZ closfil ; :Close file
CMP.B AH,#$80
JZ closeall ; :Close all files
dodos PUSH BP ; save this
INT msdos
POP BP ; restore it
RET ; '
openfil PUSH SI ; put file into table of
PUSH CX ; open files, open/create it
MOV SI,filtabpt ; start of file table
MOV CX,filemax
openlp CMP [SI],#$00 ; empty ?
JZ opendoit ; :yes
INC SI
INC SI
LOOP openlp ; another one
POP CX ; restore regs
POP SI
MOV AX,#$0004 ; Error: file not open
STC
RET ; '
opendoitPOP CX ; get offset to filename
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
CALL dodos ; open file
POP DS ; restore DS
JB openerr ; :error
MOV [SI],AX ; file handle -> file list
openerr POP SI ; restore
RET ; "
closfil PUSH CX ; Close file
PUSH SI
MOV SI,filtabpt ; start of file table
MOV CX,filemax
closlp CMP [SI],BX ; is it this file ?
JNZ clsother ; :no
MOV [SI],#$0000 ; clear its entry
clsotherINC SI ; next one
INC SI
LOOP closlp ; :not yet done
POP SI ; restore regs
POP CX
JMP dodos ; 'do it
closeallMOV SI,filtabpt ; Close all files
MOV CX,filemax
clall1 MOV BX,[SI] ; test all file handles
OR BX,BX
JZ clall2 ; :not open
MOV AH,#$3E ; close file
CALL dodos ; do it
MOV [SI],#$0000 ; store a 0: closed
clall2 INC SI ; next one
INC SI
LOOP clall1 ; :continue
RET ; "
initio XOR AX,AX ; Init files, I/O
initioflMOV modeflg,AX ; clear flag
MOV DI,#filetab ; set pt to file tab
MOV filtabpt,DI
MOV filemax,CX ; CX=max number of open files
XOR AX,AX ; clear file list
PUSH DS ; DS -> ES
POP ES
CLD
REPZ
STOS
MOV ES,AX ; segment 0:
ES:
MOV verrhnd,#errhndl ; set vector:
ES: ; error handler
MOV verrhnd1,CS
CALL msspeed ; measure CPU speed
reinit1 MOV.B cbreak,#$00 ; no test for break
reinit2 MOV SI,#inittab ; transfer vectors into table
MOV DI,#vkbdstat
PUSH DS ; DS -> ES
POP ES
PUSH CS ; CS -> DS
POP DS
MOV CX,#$001E ; count
CLD
REPZ ; move it
MOVS
PUSH ES ; restore DS
POP DS
XOR AX,AX ; clear vars
MOV lastkey,AX ; no key stored
MOV errnum,AL ; no error
MOV conbufpt,AX ; no con buf
MOV conbfend,AX
MOV.B conbufln,#$7E
MOV.B coninbuf,#$0D ; mark end of buffer
RET ; "
inittab W kbdstat,kbdget,crtput,lstput,auxput,auxget,crtput,kbdget
W $FFFF,$00C1,$FFFF,$0082,$FFFF,$0043,$FFFF,$00C4,$FFFF
W $00C5,$FFFF,$00C1,$0000,$0000,$0000,$0000,$FFFF,$00C1
W $0000,$0000,$0000,$0000 ; "
errhndl IRET ; "Error handler
conput PUSH BX ; put to CON
PUSH CX ; save registers
PUSH DX
PUSH DI
PUSH SI
XOR.B AH,AH
PUSH AX ; char to put
CALL [vconput] ; put it
conret POP SI ; restore regs
POP DI
POP DX
POP CX
POP BX
RET ; "
keyget PUSH BX ; Get from KBD
PUSH CX ; save regs
PUSH DX
PUSH DI
PUSH SI
DEC SP
CALL [vkbdget] ; do it
JMP conret ; "restore
prints PUSH BP ; Print inline string
MOV BP,SP
XCHG BX,[BP]$02 ; return addr -> BX
prsl CS:
MOV.B AL,[BX] ; get char
INC BX ; go to next one
OR.B AL,AL ; test it
JZ prsend ; 0:end
CALL conput ; put to CRT
JMP prsl ; 'continue
prsend XCHG BX,[BP]$02 ; restore ret to pos after text
POP BP
RET ; "
xwritelnCALL prints ; Writeln CRT
B $0D,$0A,$00 ; print string: CR,LF
RET ; "
upcase CMP AL,#$61 ; UpCase. < a ?
JB upcas1 ; :not lower case
CMP AL,#$7A ; > z ?
JA upcas1 ; yes:not lower case
SUB AL,#$20 ; change to upper
upcas1 RET ; "
whexwordPUSH AX ; Write Hex number: save it
MOV.B AL,AH ; do hi byte
CALL whexbyte ; do it
POP AX ; restore lo byte
whexbytePUSH AX ; write hex byte: save low nibble
ROR.B AL,1 ; get hi nibble
ROR.B AL,1
ROR.B AL,1
ROR.B AL,1
CALL whexnib ; do digit
POP AX ; get lo nibble
whexnib AND AL,#$0F ; mask it
ADD AL,#$90 ; convert to hex - tricky
DAA
ADC AL,#$40
DAA
JMP conput ; "now print it
limstindOR.B AH,AH ; limit string index
JZ limst1 ; :ok
STC ; hi <> 0: error
MOV AX,#$0000 ; clear it
JS limst1 ; negative:0
DEC.B AL ; +:255
limst1 RET ; "
; Init Memory - with inline parms:
; + 0:mode flag
; 1=direct mode 2=no device checking
; 4=test for break 8=set breakpoint interrupt
; + 2:CS for returning to Turbo
; + 4:DS for returning to Turbo
; + 6:CS size
; + 8:DS size
; + A:heap, stack size
; + C:max. heap, stack size
; + E:max. number of open files
; +10:size of std input buffer
; +12:size of std output buffer
initmem CALL readvers ; Init memory - with inline parms
POP SI ; ret addr
MOV AX,CS ; calculate segments
CS:
ADD AX,[SI]$06 ; +CS size
CS:
ADD AX,[SI]$08 ; +DS size
CS:
ADD AX,[SI]$0A ; +heap, stack size
CS:
CMP AX,availmem ; > available memory ?
JBE memin1 ; :no
JMP memerr ; 'Not enough memory
memin1 MOV BX,CS ; CS + CS size -> DS
CS:
ADD BX,[SI]$06
MOV DS,BX
CS: ; DS + DS size -> beg of free mem
ADD BX,[SI]$08
CS:
MOV DX,availmem
SUB DX,BX ; how much is left ?
CS:
CMP DX,[SI]$0C ; > max size ?
JB memin2 ; :no
CS:
MOV DX,[SI]$0C ; limit to max size
memin2 MOV DI,DX ; DI: heap size
MOV AX,#$FFFE ; value for full stack
SUB DX,#$1000 ; 64 K free ?
JNB memin3 ; :yes
MOV AX,DX ; calculate stack size -> AX
ADD AX,#$1000
MOV CL,#$04
SHL AX,CL
XOR DX,DX ; at beg of heap segment
memin3 ADD DX,BX ; + heap segment
MOV SS,DX ; -> SS
MOV SP,AX ; set SP
MOV spval,AX ; remember SP
XOR AX,AX ; clear heap:
MOV hptop,AX ; ptrs to beg of free memory
MOV hptop1,BX
MOV hpstrt,AX
MOV hpstrt1,BX
PUSH DI ; save heap size
LES DI,hpstrt ; init heap:
MOV CX,#$0004 ; mark heap top
CLD
REPZ
STOS
POP DI ; restore heap size
CS: ; return excess memory ?
TEST [SI],#$0001
JNZ memin4 ; direct mode:no
MOV AX,CS ; CS -> ES
MOV ES,AX
ADD BX,DI ; Heap pos + Heap size
SUB BX,AX ; -> top of used memory
MOV AH,#$4A ; change memory blocks
CALL dos ; do MS-DOS
memin4 CS: ; set variables
MOV AX,[SI]$02 ; CS for return
MOV turbocs,AX
CS:
MOV AX,[SI]$04 ; DS for return
MOV turbods,AX
CS:
MOV AX,[SI] ; main flag
CS:
MOV CX,[SI]$0E ; max file count
PUSH CX
PUSH SI
CALL initiofl ; init files, I/O
POP SI
POP CX
MOV DI,#filetab ; get end addr
ADD DI,CX ; of file tab
ADD DI,CX
MOV stdinof,DI ; buffer addr std input
CS:
MOV AX,[SI]$10 ; set std in buffer
MOV stdinsz,AX
ADD DI,AX
OR AX,AX
JZ memin5 ; :no std in file
MOV stdin,#$0000 ; set handle: std in
MOV.B stdinfl,#$00 ; clear flag
memin5 MOV stdoutof,DI ; buffer addr std output
CS:
MOV AX,[SI]$12 ; set std out buffer
MOV stdoutsz,AX
OR AX,AX
JZ memin6 ; :no std out file
MOV stdout,#$0001 ; set handle: std out
MOV.B stdoutfl,#$00 ; clear flag:not open
memin6 ADD SI,#$14 ; set return addr
PUSH SI
XOR AX,AX ; 0 -> ES
MOV ES,AX
ES: ; save div / 0 interrupt
MOV AX,div0vec
MOV svintv,AX
ES:
MOV AX,availmem ; div0vec1
MOV svintv1,AX
ES: ; now set own routine
MOV div0vec,#div0err
ES:
MOV availmem,CS ; div0vec1
TEST modeflg,#$0008 ; set breakpoint int ?
JZ memin7 ; :no
ES:
MOV int3vec,#brkint
ES:
MOV int3vec1,CS
memin7 TEST modeflg,#$0004 ; test for ^C, ^S ?
JZ memin8 ; :no
MOV.B cbreak,#$01 ; set flag
memin8 MOV verror,#$10D0 ; set error vec
XOR AX,AX
MOV errpos2,AX ; clear error pos
MOV ovrpnbuf,AL ; clear ovrlay pathname
MOV CX,stdinsz ; open std in for read
PUSH DS
MOV DI,#stdin
CALL xresettx
MOV CX,stdoutsz ; open std out for write
PUSH DS
MOV DI,#stdout
CALL xrewrttx
MOV.B errio,#$00 ; clear flag
CALL xcrtinit ; CrtInit
RET ; "
readversMOV AH,#$30 ; Read Version Number
CALL dos ; do MS-DOS
OR.B AL,AL ; Version 0 ?
JZ verserr ; yes:error
RET ; '
verserr MOV DX,#msgdos
JMP.b writerr ; '
memerr MOV DX,#msgmem
writerr PUSH CS ; CS -> DS
POP DS
MOV AH,#$09 ; print string
CALL dos ; do MS-DOS
MOV DX,#msgend
MOV AH,#$09 ; print string
CALL dos ; MS-DOS
MOV AH,#$00 ; exit program
CALL dos ; "do MS-DOS
msgmem B "Not enough memory$"
msgdos B "Incorrect DOS version$"
msgend B $0D,$0A,"Program aborted ; "
progend PUSH AX ; End of program
PUSH DS ; AX=0:normal
MOV DI,#stdin ; close std input
CALL xclosetx
PUSH DS
MOV DI,#stdout ; close std output
CALL xclosetx
XOR AX,AX ; restore div / 0 int
MOV ES,AX
MOV AX,svintv
ES:
MOV div0vec,AX
MOV AX,svintv1
ES:
MOV availmem,AX ; div0int1
POP AX ; end flag
TEST modeflg,#$0001 ; direct mode ?
JNZ turbort ; yes: return to Turbo
MOV AH,#$4C ; end process
CALL dos ; 'return to MS-DOS
turbort MOV AH,#$80 ; close all files
CALL dos
PUSH turbocs ; set return addr
MOV AX,#turboret
PUSH AX
PUSH DS ; DS -> ES
POP ES
MOV DS,turbods
RETF ; "return to Turbo
; Uncrunch program
; This routine makes space for overlays, which are not stored
; in the main code file. It makes use of an inline data structure:
; + 0:length of the block to move
; + 2:destination addr of this block
; This makes a list which continues at the end of each block.
uncrunchPOP BX ; return addr
CS:
MOV AX,[BX] ; get block length
OR AX,AX ; 0 ?
JZ uncrdone ; yes:end of list
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
PUSH CS ; CS -> ES
POP ES ; push list on stack
XOR DX,DX ; count blocks
uncrlistMOV AX,[BX] ; get word
OR AX,AX ; end of list ?
JZ uncrstrt ; :yes
PUSH BX ; push offset
ADD BX,AX ; add offset
INC DX ; count entry
JMP uncrlist ; 'continue
uncrstrtMOV CX,BX ; last ptr
POP BX ; get ptr from stack
MOV SI,BX ; +4 -> beginning of block
ADD SI,#$04
MOV DI,[BX]$02 ; get destination addr
CMP SI,DI ; the same ?
JZ uncrno
SUB CX,SI ; block length
ADD SI,CX ; ptrs to last byte in block
ADD DI,CX
DEC SI
DEC DI
STD ; move backwards
REPZ
MOVS.B
uncrno DEC DX ; another block ?
JNZ uncrstrt ; :yes
MOV [BX],#$0000 ; clear the list: uncrunched
POP DS ; restore DS
uncrdoneADD BX,#$04 ; skip inline data
JMP BX ; "return
; Overlay header. Inline parameters:
; + 0:currently valid procedure (ptr into file)
; + 2:name of the overlay file
; + F:start of the procedure code
rdover POP SI ; get return addr
CS: ; DX = file offset of proc wanted
CMP DX,[SI] ; is it already there ?
JNZ ovrread ; :no
ovrcall ADD SI,#$0F ; skip filename
JMP SI ; 'jump into procedure
ovrread PUSH AX ; AX = overlay length
PUSH DX ; save overlay pos
PUSH SI ; save dest addr
MOV DI,#ovrpnbuf ; scan overlay pathname
XOR.B AL,AL ; clear char buffer
ovrscan MOV.B AH,AL ; buffer:last char
MOV.B AL,[DI] ; get char
OR.B AL,AL ; end of name ?
JZ ovrpne ; :yes
INC DI ; next char
JMP ovrscan ; 'continue scanning
ovrpne PUSH DI ; save end pos
OR.B AH,AH ; test last char
JZ ovrnob ; :no path specified
CMP.B AH,#$3A ; : ?
JZ ovrnob ; :yes
CMP.B AH,#$5C ; \ ?
JZ ovrnob ; :yes
MOV.B [DI],#$5C ; store a \ at the end
INC DI
ovrnob INC SI ; set to beg of filename
INC SI
ovrcopy CS: ; get char from filename
MOV.B AL,[SI]
MOV.B [DI],AL ; store in pathname
INC SI
INC DI ; next char
OR.B AL,AL ; end ?
JNZ ovrcopy ; no: continue
MOV AX,#$3D00 ; open file
MOV DX,#ovrpnbuf ; pathname
PUSH DS ; DS -> ES
POP ES
CALL dos ; do it
MOV BX,AX ; file handle
POP DI ; restore parms
POP SI
POP DX
MOV.B [DI],#$00 ; restore overlay pathname
JB ovrerr ; :error
CS: ; store pos as current pos
MOV [SI],DX ; in the overlay header
MOV AX,#$4200 ; seek absolute
XOR.B CH,CH ; pos = DX*256
MOV.B CL,DH
MOV.B DH,DL
XOR.B DL,DL
CALL dos ; do it
POP CX ; restore length
JB ovrerr ; :error
MOV AH,#$3F ; read byte block
LEA DX,[SI]$0F ; destination addr
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
CALL dos ; do it
POP DS ; restore DS
JB ovrerr ; :error
MOV AH,#$3E ; close file
CALL dos
JMP ovrcall ; 'jump into procedure
ovrerr MOV DL,#$F0 ; error: Overlay not found
PUSH SI ; return addr
JMP runerrrt ; "
xovrpathPOP BX ; OvrPath
CALL getpn ; convert string -> ASCIIZ
PUSH BX ; restore ret
MOV SI,#pnbuf ; copy into overlay pathname
MOV DI,#ovrpnbuf
PUSH DS ; DS -> ES
POP ES
MOV CX,#$0020 ; 64 bytes
CLD
REPZ
MOVS
RET ; "
xkeypresDEC SP ; KeyPressed
CALL [vkbdstat] ; check status
RET ; "
xgotoxy POP BX ; GotoXY
POP CX ; column
PUSH BX ; restore ret
MOV.B DL,AL ; row-1
MOV.B DH,CL ; column-1
DEC.B DL ; (Turbo uses origin 1,1)
DEC.B DH
JMP setcpos ; "set position
xparmstrMOV DX,AX ; ParamStr: # wanted string
OR DX,DX ; 0 ?
JZ prmstr1
CALL prmcnt1 ; search in parm line
XCHG AX,BX ; string length -> AX
prmstr1 POP BX ; return addr
SUB SP,AX ; allot space for string
DEC SP
MOV DI,SP ; string dest
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
CLD ; move string
STOS.B ; store length
XCHG AX,CX ; -> count
REPZ ; move string
MOVS.B
POP DS ; restore DS
JMP BX ; "return
xparmcntXOR DX,DX ; ParamCount: count string entries
prmcnt1 MOV DI,#paramlin ; parameter line
CS:
MOV.B CL,[DI] ; length of param line
XOR.B CH,CH
INC DI ; beginning of string
XOR BX,BX ; clear parm cnt
prmcsep JCXZ prmcst ; :end of line
CS: ; search char <> tab, space
MOV.B AL,[DI] ; read char
CMP AL,#$20 ; space ?
JZ prmcsep2 ; :continue
CMP AL,#$09 ; tab ?
JNZ prmcst ; no:start of parm
prmcsep2INC DI ; next char
DEC CX ; count length
JMP prmcsep ; 'continue
prmcst MOV SI,DI ; start of parm string
prmcstl JCXZ prmcste ; end of line
CS: ; search char = tab, space
MOV.B AL,[DI] ; get char
CMP AL,#$20 ; space ?
JZ prmcste ; yes: end of parm
CMP AL,#$09 ; tab ?
JZ prmcste ; yes: end of parm
INC DI ; next char
DEC CX ; count length
JMP prmcstl ; 'continue searching
prmcste MOV AX,DI ; end position - beg position
SUB AX,SI
JZ prmcrt ; =0:forget it
INC BX ; count parm
DEC DX ; search another parm ?
JNZ prmcsep ; :yes
prmcrt XCHG AX,BX ; return count, string length
RET ; "
xstrint MOV.B fmtfield,CL ; Str(Integer): max length
MOV fmtsdst,DI ; dest ofs
POP BX ; ret addr
POP fmtsdst1 ; dest seg
POP CX ; format
POP AX ; number
PUSH BX ; restore ret
PUSH CX ; save format
MOV BX,#pnbuf ; dest buffer
CALL intasc ; Integer -> ASCII
JMP.b str1 ; 'store in string
xstrrealMOV.B fmtfield,CL ; Str(Real): max length
MOV fmtsdst,DI ; dest ofs
POP BX ; ret addr
POP fmtsdst1 ; dest seg
POP DX ; format 2
POP AX ; format 1
MOV DI,#recvbuf ; buffer for real number
POP [DI] ; pop real number
POP [DI]$02
POP [DI]$04
PUSH BX ; restore ret
PUSH AX ; format 1
XCHG AX,CX ; format 2 -> AX
MOV BX,#pnbuf ; dest buffer
CALL fmtreal ; Real -> ASCII
str1 POP CX ; format
LES DI,fmtsdst ; ptr to dest string
PUSH DI ; save begin pos
MOV.B DL,fmtfield ; max. field size
XOR.B DH,DH
XCHG AX,BX ; endposition - buffer pos
SUB AX,#pnbuf ; -> length
SUB CX,AX ; max len - len
JBE strcpy0 ; :too long
strpad INC DI ; pad with spaces
ES:
MOV.B [DI],#$20
INC.B DH ; count len
CMP.B DH,DL ; = max len ?
JZ strdone ; yes:done
LOOP strpad ; continue padding
strcpy0 XCHG AX,CX ; num len -> CX
MOV BX,#pnbuf ; source ptr
strcopy MOV.B AL,[BX] ; get char
INC BX ; ptr to next
INC DI
ES:
MOV.B [DI],AL ; store in string
INC.B DH ; pos = max len ?
CMP.B DH,DL
JZ strdone ; yes: end it
LOOP strcopy ; continue
strdone POP DI ; restore dest ptr
ES:
MOV.B [DI],DH ; store length
RET ; "
xvalint XOR.B AL,AL ; Val(Integer)
JMP.b val1 ; '
xvalrealMOV AL,#$01 ; Val(Real)
val1 MOV fmttype,AL ; store type
MOV fmtpdst,DI ; pos ofs
POP BX ; ret addr
POP fmtpdst1 ; pos seg
POP fmtvdst ; dest ofs
POP fmtvdst1 ; dest seg
CALL getstz ; get string from stack
PUSH BX ; restore ret
XOR AX,AX ; no error
MOV BX,#pnbuf
CMP.B [BX],AL ; null string ?
JZ valrt ; :set pos, no change to dest
CMP.B fmttype,AL ; integer ?
JNZ val2 ; :no
CALL ascint ; ASCIIZ -> Integer
JB valerr ; :error
LES DI,fmtvdst ; dest ptr
ES:
MOV [DI],AX ; store result
JMP.b valend ; 'get error pos
val2 MOV DI,#recvbuf ; real dest
CALL ascreal ; ASCIIZ -> Real
JB valerr ; :error
MOV SI,DI
LES DI,fmtvdst ; move real into
CLD ; dest var
MOVS
MOVS
MOVS
valend XOR AX,AX ; no error
CMP.B [BX],AL ; end of buffer reached ?
JZ valrt ; :yes
valerr XCHG AX,BX ; calculate error pos
SUB AX,#pnbuf0
valrt LES DI,fmtpdst ; store error pos
ES:
MOV [DI],AX
RET ; "
getpn MOV CX,#$0040 ; get string from stack
JMP.b gstz1 ; 'max 64 chars
getstz MOV CX,#$007F ; max 127 chars
gstz1 MOV DI,#pnbuf ; dest buffer (redundant!)
POP AX ; ret addr
MOV SI,SP ; ptr to string
SS:
MOV.B DL,[SI] ; get length
XOR.B DH,DH
CMP CX,DX ; > max length ?
JBE gstz2 ; yes, limit it
MOV CX,DX ; take this length
gstz2 INC DX
INC SI ; skip length
MOV DI,#pnbuf ; dest ptr
PUSH DS ; DS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS
CLD
REPZ ; move string into buffer
MOVS.B
PUSH ES ; restore DS
POP DS
MOV.B [DI],#$00 ; store a 0 at the end
ADD SP,DX ; remove string from stack
JMP AX ; "return
xrndmizeMOV AH,#$2C ; Randomize: Get time
CALL dos
MOV rndseed1,CX ; store as random seed
MOV rndseed,DX
RET ; "
xmovevarPOP BX ; Move var - CX = length
MOV DX,DS ; save DS
MOV SI,DI ; source ofs
POP DS ; source seg
POP DI ; dest ofs
POP ES ; dest seg
CLD ; move var
REPZ
MOVS.B
MOV DS,DX ; restore DS
JMP BX ; "return
xblkparmPOP BX ; Copy var -> stack
MOV DX,DS ; save DS
MOV SI,DI ; source ofs
POP DS ; source seg
SUB SP,CX ; make space - CX = len
MOV DI,SP ; dest ptr
PUSH SS ; SS -> ES
POP ES
CLD ; move it
REPZ
MOVS.B
MOV DS,DX ; restore DS
JMP BX ; "return
xfillchrPOP BX ; FillChar
POP CX ; number of bytes
POP DI ; array ofs
POP ES ; array seg
CLD ; fill it - char in AL
REPZ
STOS.B
JMP BX ; "return
xmove XCHG AX,CX ; Move: Count -> CX
MOV DX,DS ; save DS
POP BX ; ret addr
POP DI ; dest ofs
POP ES ; dest seg
POP SI ; source ofs
POP DS ; source seg
CLD ; forward move
CMP SI,DI ; source > dest ?
JNB domove ; yes: move forward
ADD SI,CX ; set ptr to end of block
ADD DI,CX
DEC SI
DEC DI
STD ; move backwards
domove REPZ ; do it
MOVS.B
MOV DS,DX ; restore DS
JMP BX ; "return
xsetregsPOP BX ; Get parms for MsDos, Intr
POP AX ; record seg
PUSH BP ; save regs
PUSH DS
PUSH AX ; save record addr
PUSH DI
PUSH BX ; restore ret
MOV SI,DI ; pointer -> source
MOV DS,AX ; source segment
CLD
LODS ; AX value -> stack
PUSH AX
LODS ; BX value
MOV BX,AX
LODS ; CX value
MOV CX,AX
LODS ; DX value
MOV DX,AX
LODS ; BP value
MOV BP,AX
LODS ; SI value -> stack
PUSH AX
LODS ; DI value
MOV DI,AX
LODS ; DS value
PUSH AX
LODS ; ES value
MOV ES,AX
POP DS ; get DS,SI,AX from stack
POP SI
POP AX
RET ; "
xgetregsPUSHF ; store register values
PUSH ES
PUSH DI
PUSH BP
MOV BP,SP ; stack index
LES DI,[BP]$0A ; get record ptr
CLD ; store AX
STOS
MOV AX,BX ; store BX
STOS
MOV AX,CX ; store CX
STOS
MOV AX,DX ; store DX
STOS
POP AX ; store BP (from stack)
STOS
MOV AX,SI ; store SI
STOS
POP AX ; store DI (from stack)
STOS
MOV AX,DS ; store DS
STOS
POP AX ; store ES (from stack)
STOS
POP AX ; store flags (from stack)
STOS
POP BX ; return addr
ADD SP,#$04 ; clear stack
POP DS ; restore DS,BP
POP BP
JMP BX ; "return
xindchk CMP AX,CX ; array index check
JNB chklim1 ; AX>=limit CX:error
RET ; '
chklim1 MOV DL,#$90 ; Index out of range
JMP.b runerrrt ; "
NOP ; Range check CX<=AX<=DX
xrngchk CMP AX,CX
JL chkrng1 ; not enough:error
CMP AX,DX
JG chkrng1 ; too much:error
RET ; '
chkrng1 MOV DL,#$91 ; Scalar or subrange
JMP.b runerrrt ; "out of range
NOP ; Stack check
xchkstk MOV AX,SP ; CX=space required
SUB AX,CX ; SP-CX
JB chkstk1 ; :error
CMP AX,#$0200 ; getting tight ?
JB chkstk1 ; :yes
MOV CL,#$04 ; convert to segment
SHR AX,CL
MOV CX,SS
ADD AX,CX
CMP AX,hptop1 ; compare with heap top
JB chkstk1 ; below:error
RET ; '
chkstk1 MOV DL,#$FF ; heap / stack collision
JMP.b runerrrt ; "
NOP ; Breakpoint interrupt
brkint POP BX ; return addr
POP AX ; AX
POPF ; Flags
PUSH BX ; restore ret
OR.B cbreak,#$02 ; set flag: int test
DEC SP
CALL kbdstat ; Key pressed ?
JZ brkno ; :no
DEC SP
CALL kbdget ; get that key
brkno AND.B cbreak,#$01 ; restore flag
CMP AL,#$03 ; ^C ?
JZ brkbrk ; :yes
RET ; '
brkbrk POP errpos ; get return addr
ADD errpos,#$02 ; adjust for length of INT3
brkmsg MOV DX,#$0001 ; error: break
JMP.b error ; "
xiores XOR AX,AX ; IOResult: clear AX
XCHG.B AL,errnum ; read error, clear it
RET ; "
xiochk CMP.B errnum,#$00 ; check for I/O-error
JNZ chkioerr
RET ; '
chkioerrMOV.B DL,errnum ; get error number
MOV DH,#$01 ; I/O-error
JMP.b error ; 'display message
div0err POP BX ; Div/0 interrupt
POP AX ; take stuff from stack
POPF
PUSH BX ; restore ret
MOV DL,#$04 ; div / 0
runerrrtPOP errpos ; error pos: return addr
runerr MOV DH,#$02 ; runtime error
error PUSH DX ; save error number
CALL reinit1 ; reinit files, I/O
POP DX ; error number
MOV AX,errpos
SUB AX,#$0003
XCHG AX,errpos2 ; store pos of call
OR AX,AX ; break ?
JNZ errbrk ; :yes
PUSH DX ; save error number
PUSH DX
PUSH errpos2
CALL [verror] ; error handler
POP DX ; restore err number
errbrk CMP.B DH,#$01 ; Break ?
JNB errrunio ; :no
CALL prints
B "^C",$0D,$0A,"User Break",$00
JMP.b errwpos ; '
errrunioMOV.B errio,#$FF ; set flag: real error
JA errrun ; :runtime error
CALL prints
B $0D,$0A,"I/O",$00
JMP.b errerr ; '
errrun CALL prints
B $0D,$0A,"Run-time",$00
errerr CALL prints
B " error ",$00
MOV.B AL,DL ; write error number
CALL whexbyte ; (hex)
errwpos CALL prints
B ", PC=",$00
MOV AX,errpos2 ; display error pos
CALL whexword
CALL prints
B $0D,$0A,"Program aborted",$0D,$0A,$00
MOV AL,#$01 ; Program end: error
JMP progend ; "
RET $0004 ; "Error handler
iabs OR AX,AX ; Abs(Integer):test sign
JNS iabspos ; :positive, zero
NEG AX ; negate it
iabspos RET ; "
irandom PUSH AX ; Random(Integer):save limit
CALL dorandom ; do random
POP BX ; get limit
SHR AX,1 ; div 2
CWD
DIV BX ; do modulo
XCHG AX,DX ; remainder -> AX
RET ; "
dorandomMOV BX,rndseed1 ; do random
MOV CX,rndseed ; get seed
PUSH BX ; save it
PUSH CX
MOV.B AL,BH ; permutate it
MOV.B BH,BL
MOV.B BL,CH
MOV.B CH,CL
XOR.B CL,CL
RCR.B AL,1
RCR BX,1
RCR CX,1
POP AX ; old seed
ADD CX,AX ; add it
POP AX
ADC BX,AX
MOV AX,#$62E9 ; add constant
ADD CX,AX
MOV AX,#$3619
ADC BX,AX
MOV rndseed1,BX ; new seed
MOV rndseed,CX
MOV AX,BX ; result
RET ; "
intasc OR AX,AX ; Integer -> ASCII
JNS iapos ; :positive number
NEG AX ; negate it
MOV.B [BX],#$2D ; store a -
INC BX
iapos XOR.B CH,CH ; flag for leading zeroes
MOV DX,#$2710 ; digit 10000
CALL iadigit
MOV DX,#$03E8 ; digit 1000
CALL iadigit
MOV DX,#$0064 ; digit 100
CALL iadigit
MOV DL,#$0A ; digit 10
CALL iadigit
MOV.B CL,AL ; do it direct
JMP.b iadput ; 'last digit
iadigit XOR.B CL,CL ; clear digit
iadsub INC.B CL ; do successive subtraction
SUB AX,DX ; (faster than DIV)
JNB iadsub ; :continue
ADD AX,DX ; restore remainder
INC.B CH ; flag:now print zeroes
DEC.B CL ; dec number
JNZ iadput ; :ok, non-zero
DEC.B CH ; clear flag
JZ iadnoput
iadput ADD.B CL,#$30 ; convert to ASCII
MOV.B [BX],CL ; store
INC BX
iadnoputRET ; "
asccard XOR AX,AX ; Read integer number:clear result
CMP.B [BX],#$24 ; $ ?
MOV DX,#$000A ; base 10
JNZ acdec ; no:ok
MOV DL,#$10 ; base 16
acloop INC BX ; go to next char
acdec PUSH AX ; save previous result
MOV.B AL,[BX] ; get char
CALL upcase
MOV.B CL,AL ; save char
POP AX ; restore result
SUB.B CL,#$30 ; digit < 0 ?
JB acend ; :yes, end of number
CMP.B CL,#$0A ; > 9 ?
JB acdigok ; no:ok
CMP.B DL,#$10 ; base = 16 ?
JNZ acend ; no:end
SUB.B CL,#$07 ; adjust hex
CMP.B CL,#$0A ; < A ?
JB acend ; :end
CMP.B CL,#$10 ; > F ?
JNB acend ; :end
acdigok PUSH DX ; save base
MUL DX ; do multiplication
POP DX ; restore base
JB acret ; :overflow
XOR.B CH,CH ; clear hi byte
ADD AX,CX ; add digit to result
JNB acloop ; :no overflow, continue
JMP.b acret ; 'end it - overflow
acend CMP.B DL,#$10 ; base 16 ?
JZ acret ; :yes
MOV CX,AX ; CX:=number*2
ADD CX,CX
acret RET ; "
ascint MOV.B CL,[BX] ; read integer:test sign
CMP.B CL,#$2D ; - ?
JNZ aipos ; :no
INC BX ; go to next char
aipos PUSH CX ; save sign
CALL asccard ; read integer
POP CX ; restore sign
JB aichk ; :might be wrong
CMP.B CL,#$2D ; - ?
JNZ ainoneg ; :no
NEG AX ; negate it
ainoneg CLC ; no error
RET ; '
aichk CMP AX,#$8000 ; $8000 ?
JNZ aierr ; no:really error
CMP.B CL,#$2D ; negative ?
JNZ aierr ; no:overflow
RET ; 'yes:ok
aierr STC ; return error
RET ; "
strload POP BX ; get string var -> stack
POP ES ; source seg
MOV SI,DI ; source ofs
ES: ; get length
MOV.B CL,[SI]
XOR.B CH,CH ; -> count
INC CX ; copy length, too
SUB SP,CX ; make space on stack
MOV DI,SP ; dest: new stack top
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
CLD ; move string to stack
REPZ
MOVS.B
POP DS ; restore DS
JMP BX ; "return
xstrcn POP SI ; inline string -> stack
CS: ; get length
MOV.B CL,[SI]
XOR.B CH,CH ; -> count
INC CX ; copy length, too
SUB SP,CX ; make space on stack
MOV DI,SP ; dest: new stack top
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
CLD ; move string to stack
REPZ ; puts SI to end of string
MOVS.B
POP DS ; restore DS
JMP SI ; "return
strstorePOP DX ; store string from stack
MOV.B AL,CL ; max. length dest
MOV BX,SP ; stack base
SS: ; get length of source string
MOV.B CL,[BX]
XOR.B CH,CH
ADD BX,CX ; add to stack base
INC BX ; +1
SS:
LES DI,[BX] ; get dest ptr
MOV SI,SP ; source ptr:stack
CMP.B CL,AL ; too long ?
JBE stslenok ; :yes
MOV.B CL,AL ; take real length
SS:
MOV.B [SI],AL ; store length on stack
stslenokINC CX ; count
PUSH DS ; save DS
PUSH SS ; SS -> DS
POP DS
CLD ; move string
REPZ
MOVS.B
POP DS ; restore DS
LEA SP,[BX]$04 ; remove string, ptr
JMP DX ; "return
xldarrchPOP BX ; store string on stack
POP ES ; source seg
MOV SI,DI ; source ofs
XOR.B CH,CH ; CL=length
SUB SP,CX ; make space on stack
DEC SP
MOV DI,SP ; dest addr
SS:
MOV.B [DI],CL ; store length
INC DI
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
CLD ; move to stack
REPZ
MOVS.B
POP DS ; restore DS
JMP BX ; "return
xstrparmPOP BX ; String insert / delete
XOR.B CH,CH ; CL=length
MOV SI,SP ; string pos
SS:
MOV.B AL,[SI] ; get length
XOR.B AH,AH
SUB AX,CX ; compare length
MOV DI,SI ; dest ptr
ADD DI,AX ; + difference
OR AX,AX ; test direction
JZ strret ; :same length
JNS strins ; :make it shorter
MOV SP,DI ; new stack top
SS: ; insert - make string longer
MOV.B CL,[SI] ; get length
INC CX ; +1 -> count
PUSH DS ; save DS
PUSH SS ; SS -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
CLD ; move it
REPZ
MOVS.B
POP DS ; restore DS
JMP.b strret ; 'return
strins SS: ; delete - shorten string
MOV.B [SI],CL ; store new length
ADD DI,CX ; go to end of string
ADD SI,CX
INC CX ; count+1
PUSH DS ; save DS
PUSH SS ; SS -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
STD ; move it up
REPZ
MOVS.B
POP DS ; restore DS
INC DI ; beginning of string
MOV SP,DI ; = new stack top
strret JMP BX ; "return
csteq CALL cmpstr ; Compare strings =
MOV AX,#$0001
JZ csteq1 ; equal:true
DEC AX ; false
csteq1 OR AX,AX ; set flags
RET ; "
cstne CALL cmpstr ; Compare strings <>
MOV AX,#$0001
JNZ cstne1 ; not equal:true
DEC AX
cstne1 OR AX,AX
RET ; "
cstge CALL cmpstr ; Compare strings >=
MOV AX,#$0001
JNB cstge1 ; larger or equal:true
DEC AX
cstge1 OR AX,AX
RET ; "
cstle CALL cmpstr ; Compare strings <=
MOV AX,#$0001
JBE cstle1 ; less or equal:true
DEC AX
cstle1 OR AX,AX
RET ; "
cstg CALL cmpstr ; Compare strings >
MOV AX,#$0001
JA cstg1 ; larger:true
DEC AX
cstg1 OR AX,AX
RET ; "
cstl CALL cmpstr ; Compare strings <
MOV AX,#$0001
JB cstl1 ; less:true
DEC AX
cstl1 OR AX,AX
RET ; "
cmpstr MOV DI,SP ; Compare strings
ADD DI,#$04 ; ignore 2 ret addr
SS:
MOV.B CL,[DI] ; get len second string
XOR.B CH,CH ; clr hi byte
INC DI ; ptr to beg of string
MOV SI,DI ; calc pos of first string
ADD SI,CX ; add len
SS:
MOV.B DL,[SI] ; get len first string
XOR.B DH,DH ; clr hi byte
INC SI
MOV BX,SI ; calc end pos of string
ADD BX,DX ; for removing it
MOV.B AL,CL ; second len
MOV.B AH,DL ; first len
CMP CX,DX ; compare them
JBE csshrt ; :CX already shorter
XCHG CX,DX ; shorter len -> CX
csshrt OR CX,CX ; null string ?
JZ csnull ; :yes
PUSH DS ; save DS
PUSH SS ; SS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS
CLD ; compare strings on stack
REPZ
CMPS.B
POP DS ; restore DS
JNZ csnoteq ; :not equal - flags are set
csnull CMP.B AH,AL ; compare len
csnoteq POP DX ; return addr
POP CX ; return addr caller
MOV SP,BX ; remove strings from stack
PUSH CX ; restore ret caller
JMP DX ; "return
xconcat POP errpos ; Concat: get return addr
MOV DI,SP ; pos second string
SS:
MOV.B DL,[DI] ; len2
XOR.B DH,DH
MOV SI,DI ; go to start of first string
INC SI
ADD SI,DX
SS:
MOV.B CL,[SI] ; len1
ADD.B DL,CL ; len1+len2 too long ?
JB concerr ; yes:error
SS:
MOV.B [SI],DL ; store new len
XOR.B CH,CH ; put first string in front
SUB DI,CX ; of second
MOV SP,DI ; get space on stack
INC CX ; len1+1 len2 will be overwritten
PUSH DS ; save DS
PUSH SI ; save SI
PUSH SS ; SS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS
CLD ; move first string
REPZ
MOVS.B
MOV DI,SI ; end addr of string 1
POP SI ; end pos of concat string
DEC SI
DEC DI
MOV CX,DX ; resulting length + 1
INC CX
STD
REPZ ; copy it up
MOVS.B
POP DS ; restore DS
INC DI
MOV SP,DI ; remove garbage from stack
JMP [errpos] ; 'return
concerr MOV DL,#$10 ; String too long
JMP runerr ; "
xcopy POP errpos ; Copy: get return addr
CALL limstind ; limit index (length)
MOV CX,AX ; -> CX
POP AX ; string pos
CALL chkstind ; check string index
DEC AX ; pos in string
MOV SI,SP ; addr of string
SS:
MOV.B DL,[SI] ; get length
XOR.B DH,DH
MOV DI,SP ; pos of dest
ADD DI,DX ; + length
SUB DX,AX ; length > pos ?
JBE copnull ; no - return null string
ADD SI,AX ; begin pos of substring
CMP DX,CX ; length > num ?
JBE copend ; :yes, sub goes to end
ADD SI,CX ; pos end of substring
MOV DX,CX ; new length
PUSH DS ; save DS
PUSH SS ; SS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS
STD ; move string
REPZ
MOVS.B
POP DS ; restore DS
JMP.b copmovd ; 'return result
copnull XOR DX,DX ; length = 0
copmovd XCHG SI,DI ; point to beg of new string
copend SS:
MOV.B [SI],DL ; store length
MOV SP,SI ; remove the rest
JMP [errpos] ; "return
xlength POP BX ; Length
MOV DI,SP ; pos of string
SS:
MOV.B AL,[DI] ; get length
XOR.B AH,AH ; clr hi byte
ADD SP,AX ; remove string from stack
INC SP
JMP BX ; "return
xpos POP errpos ; Pos (search substring)
MOV DI,SP ; pos of string
SS:
MOV.B DL,[DI] ; length of
XOR.B DH,DH
INC DI ; begin pos of string
MOV SI,DI ; DI:string scanned
ADD SI,DX ; go to beg of pattern str
SS:
MOV.B CL,[SI] ; get pattern len
XOR.B CH,CH
INC SI ; SI:pattern string
MOV BX,SI ; calc stack end pos
ADD BX,CX ; to remove strings
XOR AX,AX ; find position
SUB DX,CX ; DX:length difference
JB posend ; pattern too long: not found
INC AX ; pos 1
OR CX,CX ; pattern = null ?
JZ posend ; yes: found
INC DX ; number of compares
PUSH DS ; save DS
PUSH SS ; SS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS
CLD ; forward compare
posloop PUSH CX ; save parms
PUSH DI
PUSH SI
REPZ ; compare it
CMPS.B
POP SI ; restore parms
POP DI
POP CX
JZ posdone ; :found
INC AX ; next pos
INC DI
DEC DX ; another search ?
JNZ posloop ; :yes
XOR AX,AX ; not found = 0
posdone POP DS ; restore DS
posend MOV SP,BX ; remove strings
JMP [errpos] ; "return
xinsert MOV.B strdstln,CL ; Insert: max. dest len
MOV strpos,AX ; pos
POP BX ; return addr
POP strtrgt ; target string ptr
POP strtrgt1
MOV strobj,SP ; object string - on stack
MOV strobj1,SS
PUSH BX ; restore ret
LES DI,strtrgt ; target string
PUSH ES ; save ptr for storing result
PUSH DI
PUSH ES ; get target string
CALL strload ; -> stack
MOV AX,#$0001 ; Copy(target,1,pos-1)
PUSH AX
MOV AX,strpos
DEC AX
CALL xcopy ; do it
LES DI,strobj ; get obj string
PUSH ES
CALL strload ; -> stack
CALL xconcat ; concat strings
LES DI,strtrgt ; get target string
PUSH ES
CALL strload ; -> stack
PUSH strpos ; Copy(target,pos,255)
MOV AX,#$00FF
CALL xcopy ; do it
CALL xconcat ; concat strings
MOV.B CL,strdstln ; max. length
CALL strstore ; store string
JMP xlength ; "remove strings
xdelete MOV strnum,AX ; Delete: number of chars
POP BX ; ret addr
POP strpos ; pos in string
POP strtrgt ; target string
POP strtrgt1
PUSH BX ; restore ret
LES DI,strtrgt ; target string
PUSH ES ; save ptr for storing result
PUSH DI
PUSH ES ; get target
CALL strload ; -> stack
MOV AX,#$0001 ; Copy(target,1,pos-1)
PUSH AX
MOV AX,strpos
DEC AX
CALL xcopy ; do it
MOV AX,strpos
ADD AX,strnum ; pos+num
OR.B AH,AH ; test it
JNZ delnorem ; too big: nothing left
LES DI,strtrgt ; get target
PUSH ES
CALL strload ; -> stack
PUSH AX ; Copy(target,pos+num,255)
MOV AX,#$00FF
CALL xcopy ; do it
CALL xconcat ; concat strings
delnoremMOV CL,#$FF ; max len - never a problem
CALL strstore ; store string
RET ; "
xstrch POP BX ; String -> char
POP AX ; get string
DEC.B AL ; test length
JNZ stcherr ; <> 1:error
XCHG.B AL,AH ; char -> AL
JMP BX ; 'return
stcherr MOV errpos,BX ; store error position
MOV DL,#$10 ; String too long
JMP runerr ; "
xchstr MOV SI,SP ; string -> substring
SS: ; (1 char)
MOV.B BL,[SI]$02 ; length of string
XOR.B BH,BH
SS:
MOV AX,[BX_SI]$03 ; get char
MOV.B AH,AL ; char
MOV AL,#$01 ; length = 1
SS:
MOV [BX_SI]$03,AX ; store in string
RET ; "
POP BX ; return string as function result
ADD SP,DX ; forget DX bytes on stack
MOV SI,SP ; pos of string
SS:
MOV.B AL,[SI] ; get its length
CMP.B AL,CL ; = CL (expected length) ?
JZ retstrt ; yes: done
XOR.B AH,AH
ADD SI,AX ; ptr to end of string
MOV DI,SP ; destination (must be longer)
XOR.B CH,CH
ADD DI,CX ; end of destination
XCHG AX,CX ; real length -> count
INC CX ; copy length, too
PUSH DS ; save DS
PUSH SS ; SS -> DS
POP DS
PUSH SS ; SS -> ES
POP ES
STD ; move backwards
REPZ
MOVS.B
POP DS ; restore DS
INC DI
MOV SP,DI ; new stack top
retstrt JMP BX ; "return
chkstindOR.B AH,AH ; Check string index
JNZ stinderr ; > 255:error
OR.B AL,AL
JZ stinderr ; 0:error
RET ; '
stinderrMOV DL,#$11 ; Invalid string index
JMP runerr ; "
; Get set. CL=bytes used, CH=bytes empty at beginning
xldset POP BX ; ret addr
POP DX ; source seg
MOV SI,DI ; source ofs
SUB SP,#$20 ; make space on stack
MOV DI,SP ; dest ptr
PUSH CX ; save crunch byte
PUSH SS ; SS -> ES
POP ES
CLD ; forward
OR.B CH,CH ; empty bytes at beginning
JZ sld2 ; :none
XOR.B AL,AL ; store zeroes
sldclr1 STOS.B
DEC.B CH
JNZ sldclr1 ; :another
sld2 PUSH DS ; save DS
MOV DS,DX ; DX -> DS
REPZ
MOVS.B ; move set
POP DS ; restore DS
POP CX ; restore crunch byte
MOV AH,#$20 ; calculate empty bytes
SUB.B AH,CH ; at end
SUB.B AH,CL
JZ sld3 ; :none
XOR.B AL,AL ; store zeroes
sldclr2 STOS.B
DEC.B AH
JNZ sldclr2 ; :another one
sld3 JMP BX ; "return
sldemptyPOP BX ; Make empty set
SUB SP,#$20 ; 32 bytes on stack
MOV DI,SP ; dest addr
PUSH SS ; SS -> ES
POP ES
MOV CX,#$0010 ; do 32 bytes
XOR AX,AX ; fill with zeroes
CLD
REPZ
STOS
JMP BX ; "return
setincl CALL setindex ; Include element: calc index
SS:
OR.B [BX],AL ; include it
RET ; "
setinrngXCHG AX,CX ; Include range in set
POP BX ; ret addr
POP AX ; lower upper is in CX
PUSH BX ; restore ret
SUB.B CL,AL ; upper < lower ?
JB srngnil
XOR.B CH,CH ; upper-lower -> count
INC CX
MOV.B AH,CL ; save count
CALL setindex ; calc set index (lower)
MOV.B CL,AH ; restore count
srngloopSS: ; include element in set
OR.B [BX],AL
SHL.B AL,1 ; for next bit
JNB srngbit ; :ok
INC BX ; go to next byte
MOV AL,#$01
srngbit LOOP srngloop ; :another element
srngnil RET ; "
setsto MOV SI,SP ; store set. CX as with load
INC SI
INC SI ; source addr
SS:
MOV DI,[SI]$20 ; get dest ofs
SS:
MOV ES,[SI]$22 ; dest seg
MOV.B DL,CH ; # empty bytes
XOR.B DH,DH
ADD SI,DX ; add to source addr
XOR.B CH,CH ; CL = # bytes used
PUSH DS ; save DS
PUSH SS ; SS -> DS
POP DS
CLD ; move used bytes
REPZ
MOVS.B
POP DS ; restore DS
RET $0024 ; "remove set, pointer
xsetparmPOP BX ; Put set as procedure parm
MOV.B DL,CH ; bytes empty at beg
XOR.B DH,DH
XOR.B CH,CH ; bytes used
MOV SI,SP ; source addr
ADD SI,DX ; calc end pos
ADD SI,CX
MOV DI,SP ; dest addr
ADD DI,#$20
CMP SI,DI ; = end pos ?
JZ putsetrt
DEC SI ; go back one byte
DEC DI
PUSH DS ; save DS
PUSH SS ; SS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS ; set is stored as compressed
STD ; local var
REPZ
MOVS.B ; do move it
POP DS ; restore DS
INC DI
MOV SP,DI ; remove empty space
putsetrtJMP BX ; "return
seteq MOV AX,#$0001 ; Set comparison =
JMP.b setcmp ; '
setne XOR AX,AX ; Set comparison <>
setcmp CALL setptrs ; set parms
REPZ ; compare sets
CMPS
MOV DS,DX ; restore DS
JZ setceq ; :equal
XOR AX,#$0001 ; invert result
setceq OR AX,AX ; test result
RET $0040 ; "remove sets from stack
setge XOR AX,AX ; Set comparison >=
JMP.b setcmp2 ; '
setle MOV AX,#$0001 ; Set comparison <=
setcmp2 CALL setptrs ; set parms
DEC AX ; 'test type of comparison
JNZ setc2l ; :<=
XCHG DI,SI ; swap set1, set2
setc2l LODS ; get byte from set2
OR AX,[DI] ; include set1
SCAS ; compare with set1
JNZ setc2g ; :not the same
LOOP setc2l ; :continue
MOV AX,#$0001 ; true
JMP.b setc2rt ; 'end it
setc2g XOR AX,AX ; false
setc2rt MOV DS,DX ; restore DS
OR AX,AX ; test result
RET $0040 ; "remove sets from stack
sunion CALL setptrs ; Set union: set parms
sunion1 LODS ; get byte set 2
OR AX,[DI] ; include set 1
STOS ; store in set 1
LOOP sunion1 ; :continue
MOV DS,DX ; restore DS
RET $0020 ; "remove set 2 from stack
sdiff CALL setptrs ; Set difference: set parms
sdiff1 LODS ; get byte set 2
NOT AX ; invert it
AND AX,[DI] ; take it from set 1
STOS ; store in set 1
LOOP sdiff1 ; :continue
MOV DS,DX ; restore DS
RET $0020 ; "remove set 2 from stack
sinter CALL setptrs ; Set intersection: set parms
sinter1 LODS ; get byte set 2
AND AX,[DI] ; intersect set 1
STOS ; store in set 1
LOOP sinter1 ; :continue
MOV DS,DX ; restore DS
RET $0020 ; "remove set 2 from stack
xsetin MOV BX,SP ; Set IN operation
SS: ; pos of set
MOV AX,[BX]$22 ; get parm
OR.B AH,AH ; > 255 ?
JZ setintst ; no: ok
XOR AX,AX ; false
JMP.b setnotin ; 'return result
setintstCALL setindex ; calc set index
SS:
AND.B AL,[BX] ; test set element
MOV AX,#$0000 ; false
JZ setnotin ; not set: false
INC AX ; true
setnotinOR AX,AX ; test result
RET $0022 ; "remove set, parm
setindexMOV.B BL,AL ; Calculate set index, mask
XOR.B BH,BH ; BX = bit number
MOV CL,#$03 ; bit number DIV 8
SHR BX,CL
ADD BX,#$04 ; +SP+4 -> set ptr
ADD BX,SP
MOV.B CL,AL ; bit number MOD 8
AND.B CL,#$07
MOV AL,#$01 ; create bit mask
SHL.B AL,CL
RET ; "
setptrs MOV SI,SP ; Set parms for set ops
ADD SI,#$04 ; ptr set 2
MOV DI,SP ; skip two ret addrs
ADD DI,#$24 ; ptr set 1
MOV DX,DS ; save DS
PUSH SS ; SS -> ES
POP ES
PUSH SS ; SS -> DS
POP DS
MOV CX,#$0010 ; count: 32 bytes
CLD
RET ; "
ptreq CMP AX,BX ; Compare pointers DX:AX = CX:BX
MOV AX,#$0000 ; false
JNZ ptreqno ; :not equal
CMP DX,CX
JNZ ptreqno ; :not equal
INC AX ; true
ptreqno OR AX,AX ; set flags
RET ; "
ptrne CMP AX,BX ; Compare pointers <>
MOV AX,#$0001 ; true
JNZ ptrne1 ; not equal: true
CMP DX,CX
JNZ ptrne1 ; not equal: true
DEC AX ; false
ptrne1 OR AX,AX ; set flags
RET ; "
; *** Real Operations ***
; #1 #2 register usage
; AX CX LSB, exponent
; BX SI mantissa
; DX DI MSB, sign
resub MOV resign,#$8000 ; Do real subtraction
JMP.b ra1 ; '
readd MOV resign,#$0000 ; Do real addition
ra1 OR.B CL,CL ; second = 0 ?
JZ raret ; :yes, done
XOR DI,resign ; change sign2, if sub
OR.B AL,AL ; first = 0 ?
JNZ ranotriv ; :no
raretn2 MOV AX,CX ; second -> result
MOV BX,SI
MOV DX,DI
raret RET ; '
ranotrivCMP.B AL,CL ; compare exponents
JBE ranoswap ; AL <= CL !
XCHG AX,CX ; otherwhise swap numbers
XCHG BX,SI
XCHG DX,DI
ranoswapMOV.B cvdecexp,CL ; save exp2
SUB.B CL,AL ; exponent difference
CMP.B CL,#$28 ; first number too small ?
JB ranoundr ; :no
MOV.B CL,cvdecexp ; restore exp2
JMP raretn2 ; 'second -> result
ranoundrMOV resign,DI ; save MSB 2
AND.B resave,#$80 ; mask out mantissa
MOV remant,DI ; save MSB 2
XOR.B remant1,DH
OR DI,#$8000 ; remove sign
OR.B DH,#$80 ; remove sign
raadj16lCMP.B CL,#$10 ; shift first in 16-bit-steps
JB raadj8 ; :done
MOV.B AH,BH ; do it.
MOV BX,DX ; first num is shifted to make
XOR DX,DX ; exp1 = exp2
SUB.B CL,#$10
JMP raadj16l ; 'try again
raadj8 CMP.B CL,#$08 ; shift first in 8-bit-steps
JB raadj8l ; :done
MOV.B AH,BL ; do it
MOV.B BL,BH
MOV.B BH,DL
MOV.B DL,DH
XOR.B DH,DH
SUB.B CL,#$08 ; count down difference
raadj8l OR.B CL,CL ; test difference
JZ raadjend ; :adjustment done
raadj1l SHR DX,1 ; shift right in 1-bit-steps
RCR BX,1
RCR.B AH,1
DEC.B CL
JNZ raadj1l ; :continue
raadjendMOV AL,cvdecexp ; get exp2
TEST.B remant1,#$80 ; test sign
JNZ radosub ; :negative
ADD.B AH,CH ; add mantissa
ADC BX,SI
ADC DX,DI
JNB rasign ; :ok
RCR DX,1 ; do normalization
RCR BX,1
RCR.B AH,1
INC.B AL ; inc exponent
JNZ rasign ; :ok
STC ; overflow error
RET ; '
radosub XCHG.B AH,CH ; exchange numbers
XCHG BX,SI
XCHG DX,DI
SUB.B AH,CH ; subtract numbers
SBB BX,SI
SBB DX,DI
JNB ranoneg ; :no underflow
XOR.B resave,#$80 ; change sign
NOT.B AH ; negate mantissa
NOT BX ; = inverted mantissa + 1
NOT DX
ADD.B AH,#$01
ADC BX,#$00
ADC DX,#$00
ranoneg MOV CL,#$05 ; normalize number
ranrm8l OR.B DH,DH ; upper byte empty ?
JNZ ranrm1l ; :no
MOV.B DH,DL ; shift left 8 bits
MOV.B DL,BH
MOV.B BH,BL
MOV.B BL,AH
XOR.B AH,AH
SUB AL,#$08 ; sub 8 from exp
JB razero ; :underflow, return 0
DEC.B CL ; count down bytes
JNZ ranrm8l ; :another one
JMP.b razero ; 'underflow
ranrm1l TEST.B DH,#$80 ; Mantissa MSB must be 1
JNZ rasign ; :yes, done
SHL.B AH,1 ; shift left 1 bit
RCL BX,1
RCL DX,1
DEC.B AL ; sub 1 from exp
JNZ ranrm1l ; :ok
razero XOR AX,AX ; underflow, return zero
XOR BX,BX
XOR DX,DX
RET ; '
rasign AND.B DH,#$7F ; clear MSB mantissa
XOR.B DH,resave ; set correct sign
RET ; "
remult OR.B CL,CL ; Real multiplication: second=0 ?
JZ rmzero ; yes: return zero
OR.B AL,AL ; first=0 ?
JZ rmret ; yes: done
ADD.B AL,CL ; add exponents
CALL testexp ; test exponent
MOV remul11,AX ; save first number
MOV remul12,BX
MOV remul13,DX
XOR.B AH,AH ; clear result
XOR BX,BX
XOR DX,DX
MOV DI,#remul21 ; ptr to second mantissa
MOV CL,#$05 ; do 5 bytes
rmbyt INC DI ; get byte from second mantissa
MOV.B CH,[DI]
OR.B CH,CH ; 0 ?
JNZ rmdomul ; no: do multiplication
MOV.B AH,BL ; just shift result
MOV.B BL,BH ; 8 bits right
MOV.B BH,DL
MOV.B DL,DH
XOR.B DH,DH
JMP.b rmnxtbyt ; 'next step
rmdomul MOV SI,#$0008 ; do 8 bits
rmmul RCR.B CH,1 ; get bit
JNB rmbit0 ; :not set
ADD.B AH,remul11a ; add mantissa 1 to result
ADC BX,remul12
ADC DX,remul13
rmbit0 RCR DX,1 ; shift result 1 bit right
RCR BX,1
RCR.B AH,1
DEC SI ; another bit ?
JNZ rmmul ; :yes
rmnxtbytDEC.B CL ; another byte ?
JNZ rmbyt ; :yes
XCHG AX,CX ; save AX, CL
LAHF ; save flags
TEST.B DH,#$80 ; already normalized ?
JNZ rmnoadj ; :yes
SAHF ; restore flags
RCL.B CH,1 ; shift 1 bit left
RCL BX,1
RCL DX,1
OR.B CL,CL ; check exp
JZ rmnoadj ; :underflow
DEC.B CL ; sub 1 from exp
rmnoadj XCHG AX,CX ; restore AX, CL
XOR.B DH,resave ; set sign
OR.B AL,AL ; test exponent
JNZ rmret ; :ok
rmzero XOR AX,AX ; return zero
XOR BX,BX
XOR DX,DX
rmret RET ; "
rediv OR.B AL,AL ; Real division
JZ rmret ; first=0:done
SUB.B AL,CL ; sub exponents
CMC
CALL testexp ; test exponent
MOV remul11,AL ; save exponent
MOV DI,#remul21b ; ptr to dest
MOV CL,#$05 ; 5 bytes
MOV SI,#$0008 ; 8 bits
rdloop CMP DX,remul23 ; compare with num2
JNZ rdcmp
CMP BX,remul22
JNZ rdcmp
CMP.B AH,remul21a
rdcmp JB rdshft ; below:no subtraction
SUB.B AH,remul21a ; do subtraction
SBB BX,remul22
SBB DX,remul23
rdshft CMC ; invert carry
RCL.B CH,1 ; shift into result
DEC SI ; another bit ?
JNZ rdbit ; :yes
MOV.B [DI],CH ; store result byte
DEC.B CL ; another byte ?
JZ rdlast ; :no
DEC DI ; next one
MOV SI,#$0008 ; 8 bits again
rdbit SHL.B AH,1 ; shift left mantissa
RCL BX,1
RCL DX,1
JNB rdloop ; :normal step
SUB.B AH,remul21a ; carry: no comparison necessary
SBB BX,remul22 ; do subtraction
SBB DX,remul23
CLC
JMP rdshft ; 'shift in result
rdlast SHL.B AH,1 ; do last shift
RCL BX,1
RCL DX,1
JB rdshft2 ; :ok
CMP DX,remul23 ; test last step
JNZ rdcmp2
CMP BX,remul22
JNZ rdcmp2
CMP.B AH,remul21a
rdcmp2 CMC
rdshft2 MOV CX,remul11 ; get result
MOV BX,remul12
MOV DX,remul13
LAHF ; save flags
TEST.B DH,#$80 ; normalized ?
JNZ rdnrm ; :yes
SAHF ; get flags
RCL.B CH,1 ; shift left mantissa
RCL BX,1
RCL DX,1
JMP.b rdok ; 'get sign, test exponent
rdnrm INC.B CL ; inc exponent
JNZ rdok ; :ok
STC ; overflow error
RET ; '
rdok JMP rmnoadj ; "set sign, test exponent
testexp JB texovr ; test exponent: overflow ?
ADD AL,#$80 ; set offset again
JB texok ; :ok
POP BX ; forget return addr
XOR AX,AX ; return zero: underflow
XOR BX,BX
XOR DX,DX
RET ; '
texovr ADD AL,#$80 ; set offset again
JNB texok ; :no error
POP BX ; forget return addr
STC ; overflow error
RET ; '
texok MOV remul21,CX ; save LSB2
MOV CX,DX ; get sign
XOR CX,DI
NOT.B CH ; invert it
AND.B CH,#$80 ; mask sign
MOV.B resave,CH ; save sign
OR.B DH,#$80 ; set mantissa MSB
OR DI,#$8000
MOV remul22,SI ; store mantissa 2
MOV remul23,DI
RET ; "
readd2 PUSH DI ; add, keep second number
PUSH SI
PUSH CX
CALL readd ; do addition
POP CX
POP SI
POP DI
RET ; "
resub2 PUSH DI ; subtract, keep second number
PUSH SI
PUSH CX
CALL resub ; do subtraction
POP CX
POP SI
POP DI
RET ; "
remult2 PUSH DI ; multiply, keep second number
PUSH SI
PUSH CX
CALL remult ; do multiplication
POP CX
POP SI
POP DI
RET ; "
rediv2 PUSH DI ; divide, keep second number
PUSH SI
PUSH CX
CALL rediv ; do division
POP CX
POP SI
POP DI
RET ; "
recmp PUSH DX ; Real comparison
XOR DX,DI ; compare signs
POP DX ; restore
JNS rcsign ; :signs are the same
PUSH DX ; different signs: get flag
RCL DX,1
POP DX
RET ; '
rcsign TEST.B DH,#$80 ; sign ?
JZ rcnum ; :positive
CALL rcnum ; compare
JZ rcdiff ; equal: don't invert
CMC ; invert flags
RET ; '
rcnum CMP.B AL,CL ; compare exponents
JNZ rcdiff
OR.B AL,AL ; zero ?
JZ rcdiff ; yes:equal
CMP DX,DI ; compare mantissa MSB
JNZ rcdiff
CMP BX,SI
JNZ rcdiff
CMP.B AH,CH ; compare mantissa LSB
rcdiff RET ; "
intreal OR AX,AX ; Int(Integer) -> Real
JNZ irnot0 ; :not zero
XOR BX,BX ; return zero
XOR DX,DX
RET ; '
irnot0 MOV.B BH,AH ; put sign
MOV DX,AX
OR DX,DX ; test sign
JNS irpos ; :positive
NEG DX ; negate number
irpos MOV AX,#$0090 ; exp, cleared LSB mantissa
OR.B DH,DH ; test high byte
JNZ ir16bits ; :not zero
MOV AL,#$88 ; speed it up...
XCHG.B DL,DH ; shift 8 bits
ir16bitsOR DX,DX ; test mantissa MSB
JS irdone ; :ok, normalized
irnrm DEC.B AL ; count down exponent
SHL DX,1 ; shift it left
JNS irnrm ; :continue
irdone OR.B BH,BH ; negative ?
JS irpos2 ; :yes
AND.B DH,#$7F ; set positive flag
irpos2 XOR BX,BX ; clear rest of mantissa
RET ; "
reint CMP AL,#$A8 ; Int(Real) - inefficient !
JNB riret ; exponent too big - done
MOV CX,AX ; save number
MOV SI,BX
MOV DI,DX
XOR.B AH,AH ; clear mask
XOR BX,BX
XOR DX,DX
SUB.B CL,#$80 ; exponent-offset
JBE rizero ; :underflow, return zero
rim16l CMP.B CL,#$10 ; shift 16 bit ?
JB rim8 ; :done
MOV.B AH,BH ; shift right 16 bit
MOV BX,DX
MOV DX,#$FFFF ; put into mask
SUB.B CL,#$10 ; count down
JMP rim16l ; 'try again
rim8 CMP.B CL,#$08 ; shift 8 bit ?
JB rim1 ; :done
MOV.B AH,BL ; shift right 8 bit
MOV.B BL,BH
MOV.B BH,DL
MOV.B DL,DH
MOV DH,#$FF ; put into mask
SUB.B CL,#$08 ; count down
rim1 OR.B CL,CL ; shift single bits ?
JZ riand ; :done
rim1l STC ; shift in a 1
RCR DX,1 ; shift right 1 bit
RCR BX,1
RCR.B AH,1
DEC.B CL ; count down
JNZ rim1l ; :continue shifting
riand AND DX,DI ; get result:
AND BX,SI ; mask away the fraction
AND.B AH,CH
riret RET ; '
rizero XOR.B AL,AL ; return zero
RET ; "
refrac PUSH DX ; Frac - inefficient !
PUSH BX ; save original number
PUSH AX
CALL reint ; Int
MOV CX,AX ; result -> second number
MOV SI,BX
MOV DI,DX
POP AX ; restore number
POP BX
POP DX
JMP resub ; "do subtraction
xldreal POP BX ; Load real number onto stack
POP ES ; ptr
ES:
PUSH [DI]$04 ; push that number
ES:
PUSH [DI]$02
ES:
PUSH [DI]
JMP BX ; "return
xrealcn POP BX ; Get real constant (inline)
CS: ; get return addr
PUSH [BX]$04 ; push that number
CS:
PUSH [BX]$02
CS:
PUSH [BX]
ADD BX,#$06 ; skip constant
JMP BX ; "return
xstorealPOP BX ; Store real number
POP AX ; get number
POP CX
POP DX
POP DI ; get dest ptr
POP ES
ES: ; store number
MOV [DI],AX
ES:
MOV [DI]$02,CX
ES:
MOV [DI]$04,DX
JMP BX ; "return
xadd POP errpos ; Add real numbers
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL readd ; do addition
retest JB reovrerr ; :error
repush PUSH DX ; store result on stack
PUSH BX
PUSH AX
JMP [errpos] ; 'return
reovrerrMOV DL,#$01 ; Floating point overflow
JMP runerr ; "
xsub POP errpos ; Subtract real numbers
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL resub ; do subtraction
JMP retest ; "put result, return
xmul POP errpos ; Multiply real numbers
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
xmul2 CALL remult ; do multiplication
JMP retest ; "put result, return
xdiv POP errpos ; Divide real numbers
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
OR.B CL,CL ; second = 0 ?
JZ xdiverr ; yes: div / 0 error
CALL rediv ; divide
JMP retest ; 'put result, return
xdiverr MOV DL,#$02 ; Division by zero attempted
JMP runerr ; "
xneg MOV BX,SP ; Neg real: get addr of number
SS:
CMP.B [BX]$02,#$00 ; zero ?
JZ xnegzer ; :don't negate
SS:
XOR.B [BX]$07,#$80 ; invert sign
xnegzer RET ; "
xabs MOV BX,SP ; Abs real: get addr of number
SS:
AND.B [BX]$07,#$7F ; make positive
RET ; "
realeq POP errpos ; Real =
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL recmp ; compare real
PUSH errpos ; restore ret
MOV AX,#$0001 ; true
JZ realeq1 ; equal: true
DEC AX ; false
realeq1 OR AX,AX ; set flags
RET ; "
realne POP errpos ; Real <>
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL recmp ; compare real
PUSH errpos ; restore ret
MOV AX,#$0001 ; true
JNZ realne1 ; not equal: true
DEC AX ; false
realne1 OR AX,AX ; set flags
RET ; "
realge POP errpos ; Real >=
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL recmp ; compare real
PUSH errpos ; restore ret
MOV AX,#$0001 ; true
JNB realge1 ; larger or equal: true
DEC AX ; false
realge1 OR AX,AX ; set flags
RET ; "
realle POP errpos ; Real <=
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL recmp ; compare real
PUSH errpos ; restore ret
MOV AX,#$0001 ; true
JBE realle1 ; smaller or equal: true
DEC AX ; false
realle1 OR AX,AX ; set flags
RET ; "
realg POP errpos ; Real >
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL recmp ; compare real
PUSH errpos ; restore ret
MOV AX,#$0001 ; true
JA realg1 ; larger: true
DEC AX ; false
realg1 OR AX,AX ; set flags
RET ; "
reall POP errpos ; Real <
POP CX ; second number
POP SI
POP DI
POP AX ; first number
POP BX
POP DX
CALL recmp ; compare real
PUSH errpos ; restore ret
MOV AX,#$0001 ; true
JB reall1 ; smaller: true
DEC AX ; false
reall1 OR AX,AX ; set flags
RET ; "
xsqr POP errpos ; Sqr real: save ret addr
POP AX ; get number
POP BX
POP DX
MOV CX,AX ; -> second number
MOV SI,BX
MOV DI,DX
JMP xmul2 ; "do real multiplication
xint POP errpos ; Int real: save ret addr
POP AX ; get number
POP BX
POP DX
CALL reint ; do Int
JMP repush ; "push result
xfrac POP errpos ; Frac real: save ret addr
POP AX ; get number
POP BX
POP DX
CALL refrac ; do Frac
JMP repush ; "push result
xrandom CALL dorandom ; Random real
MOV DX,#$0080 ; original exponent
MOV AL,#$20 ; max. count
rrndnrm TEST.B BH,#$80 ; normalized ?
JNZ rrndok ; :yes
SHL CX,1 ; shift left 1 bit
RCL BX,1
DEC.B DL ; count down exponent
DEC.B AL ; another bit ?
JNZ rrndnrm ; :yes
XOR.B DL,DL ; return zero
rrndok AND.B BH,#$7F ; clear mantissa MSB
POP AX ; ret addr
PUSH BX ; push result
PUSH CX
PUSH DX
JMP AX ; "return
xround MOV CH,#$FF ; Round
JMP.b trunc1 ; '
xtrunc XOR.B CH,CH ; Trunc
trunc1 POP BX ; ret addr
POP AX ; get number
POP DX
POP DX
PUSH BX ; restore ret
trunc2 XCHG AX,DX ; put exp
MOV CL,#$8F ; subtract exponent
SUB.B CL,DL ; too big ?
JB truncerr ; :overflow error
CMP.B CL,#$0F ; too many shifts ?
JA trunczer ; yes: 0
INC.B CL
MOV.B BH,AH ; save sign
OR.B AH,#$80 ; set mantissa MSB
SHR AX,CL ; shift right
JNB trunc3 ; :nothing to round
OR.B CH,CH ; round up ?
JZ trunc3 ; :no
INC AX ; round it up
JS truncerr ; overflow: error
trunc3 TEST.B BH,#$80 ; sign ?
JZ truncrt ; :no
NEG AX ; negate it
truncrt RET ; '
trunczerXOR AX,AX ; return 0
RET ; '
truncerrMOV DL,#$92 ; Out of integer range
JMP runerrrt ; "
xintrealCALL intreal ; Integer -> Real
POP CX ; get ret
PUSH DX ; push number
PUSH BX
PUSH AX
JMP CX ; "return
xintre2 POP errpos ; Int -> Real
POP CX ; keep second number
POP SI
POP DI
POP AX ; integer number
CALL intreal ; do conversion
PUSH DX ; push result
PUSH BX
PUSH AX
PUSH DI ; push second number
PUSH SI
PUSH CX
JMP [errpos] ; "return
; Square root. Algorithm: Newton
; x[n+1]:=0.5*(x[n]+c/x[n]) -> Sqrt(c)
xsqrt POP errpos ; Sqrt: save ret addr
POP AX ; get number
POP BX
POP DX
MOV CX,AX ; -> second number
MOV SI,BX
MOV DI,DX
OR.B AL,AL ; zero ?
JZ sqrtdone ; yes: return
TEST.B DH,#$80 ; test sign
JNZ sqrterr ; negative: error
MOV retrc1,AX ; store number
MOV retrc2,BX
MOV retrc3,DX
ADD.B CL,#$80 ; make a guess for the
SAR.B CL,1 ; exponent
ADD.B CL,#$80
MOV.B AL,CL
SUB AL,#$14 ; end condition: difference
MOV cvexpcnt,AL ; smaller than this
sqrtloopMOV AX,retrc1 ; get original number
MOV BX,retrc2
MOV DX,retrc3
CALL rediv2 ; real division /x[n]
CALL readd2 ; real addition +x[n]
DEC.B AL ; * 0.5 = dec exponent
PUSH DX ; save x[n+1]
PUSH BX
PUSH AX ; test: end reached ?
CALL resub ; real subtraction
CMP.B AL,cvexpcnt ; test exponent
POP CX ; restore x[n+1]
POP SI
POP DI
JNB sqrtloop ; :not yet done
sqrtdonePUSH DI ; return result
PUSH SI
PUSH CX
JMP [errpos] ; 'return
sqrterr MOV DL,#$03 ; Sqrt argument error
JMP runerr ; "
; *** Transcendental functions ***
; The algorithms used can be looked up in any formulary (!!!)
xcos POP errpos ; Cos: save ret addr
POP CX ; get number
POP SI
POP DI
MOV AX,#$2181 ; -pi/2
MOV BX,#$DAA2
MOV DX,#$490F
CALL resub ; real subtraction
JMP.b sin1 ; '
xsin POP errpos ; Sin: save ret addr
POP AX ; get number
POP BX
POP DX
sin1 CMP AL,#$6C ; small number ?
JB sinpush ; yes: return immediately
MOV CX,#$2183 ; 2*pi
MOV SI,#$DAA2 ; bring into range 0..2*pi
MOV DI,#$490F
PUSH DX ; save sign
AND.B DH,#$7F ; make positive
CALL recmp ; real comparison
POP DX ; restore sign
JB sinl2pi ; :ok
CALL rediv2 ; real division, keep 2*pi
PUSH DI ; save 2*pi
PUSH SI
PUSH CX
CALL refrac ; Frac
POP CX ; restore 2*pi
POP SI
POP DI
CALL remult2 ; real mult, keep 2*pi
sinl2pi TEST.B DH,#$80 ; negative ?
JZ sinpos ; :no
CALL readd2 ; add 2*pi
sinpos DEC.B CL ; change to pi
CALL recmp ; real comparison
PUSHF ; save result
JB sinlpi ; :below
CALL resub2 ; subtract pi
sinlpi DEC.B CL ; change to pi/2
CALL recmp ; real comparison
JB sinlpi2 ; :less
INC.B CL
OR.B DH,#$80 ; add -pi
CALL readd
sinlpi2 CMP AL,#$6C ; small number ?
JB sinsmall ; yes:return
MOV DI,#fltsin ; pointer to constants
MOV CX,#$0007 ; 7 numbers
CALL poly1 ; do polynome
sinsmallPOPF ; flag: >pi
JB sinpush ; :ok
OR.B AL,AL ; neg, if not zero
JZ sinpush ; :zero
XOR.B DH,#$80 ; negate
sinpush JMP repush ; "push result
fltsin W $9D58,$9F39,$D73F ; -7.6471637318E-13 -1/15! constants for sin,cos
W $4360,$309D,$3092 ; 1.6059043837E-10 1/13!
W $AA67,$283F,$D732 ; -2.5052103056E-08 -1/11!
W $B66E,$1D2A,$38EF ; 2.7557319224E-06 1/ 9!
W $0D74,$00D0,$D00D ; -1.9841269841E-04 -1/ 7!
W $887A,$8888,$0888 ; 8.3333333333E-03 1/ 5!
W $AB7E,$AAAA,$AAAA ; -1.6666666667E-01 "-1/ 3!
xln POP errpos ; Ln (Logarithm)
POP AX ; get number
POP BX
POP DX
OR.B AL,AL ; zero ?
JZ lnerr ; yes:error
TEST.B DH,#$80 ; negative ?
JZ lnok ; :no
lnerr MOV DL,#$04 ; Ln argument error
JMP runerr ; '
lnok MOV.B CH,AH ; sign, LSB
MOV CL,#$81 ; bring into range 1..2
SUB.B AL,CL ; modify exponent
CBW
PUSH AX ; integer: exponent
XCHG AX,CX ; set new exponent
MOV CX,#$FB80 ; multiply *Sqrt(2)/2
MOV SI,#$F333
MOV DI,#$3504
CALL remult ; multiplication
MOV CX,AX ; first -> second number
MOV SI,BX
MOV DI,DX
MOV AX,#$0081 ; first number = 1
XOR BX,BX
XOR DX,DX
CALL readd2 ; addition +1
PUSH DX ; save result
PUSH BX
PUSH AX
MOV AX,#$0081 ; first = -1
XOR BX,BX
MOV DX,#$8000
CALL readd ; addition -1
POP CX ; restore result
POP SI
POP DI
CALL rediv ; division (c-1)/(c+1)
MOV DI,#fltln ; pointer to constants
MOV CX,#$0006 ; 6 numbers
CALL poly1 ; do polynome
INC.B AL ; result *2
MOV CX,#$D27F ; + ln(sqrt(2))
MOV SI,#$17F7
MOV DI,#$3172
CALL readd ; addition
POP CX ; get int exponent
PUSH DX ; save result
PUSH BX
PUSH AX
XCHG AX,CX ; exponent
CALL intreal ; -> real
MOV CX,#$D280 ; * ln(2)
MOV SI,#$17F7
MOV DI,#$3172
CALL remult ; multiplication
POP CX ; restore result
POP SI
POP DI
CALL readd ; add
CMP AL,#$67 ; do a cosmetic round-off (!!!)
JNB lnround ; :no
XOR AX,AX ; return zero
XOR BX,BX
XOR DX,DX
lnround JMP repush ; "push result
fltln W $8A7D,$D89D,$1D89 ; 7.6923076923E-02 1/13 Constants for Ln
W $E97D,$8BA2,$3A2E ; 9.0909090909E-02 1/11
W $8E7D,$38E3,$638E ; 1.1111111111E-01 1/ 9
W $497E,$2492,$1249 ; 1.4285714286E-01 1/ 7
W $CD7E,$CCCC,$4CCC ; 2.0000000000E-01 1/ 5
W $AB7F,$AAAA,$2AAA ; 3.3333333333E-01 "1/ 3
xexp POP errpos ; Exp: get return addr
POP AX ; get number
POP BX
POP DX
TEST.B DH,#$80 ; negative ?
PUSHF ; remember flag
AND.B DH,#$7F ; make it positive
MOV CX,#$D280 ; /ln(2)
MOV SI,#$17F7
MOV DI,#$3172 ; (would be faster to use mult !)
CALL rediv ; division
CMP AL,#$88 ; too much ?
JNB experr ; :yes, overflow
PUSH DX ; save number
PUSH BX
PUSH AX
INC.B AL ; * 2
MOV CH,#$FF
CALL trunc2 ; do Round
POP CX ; restore number
POP SI
POP DI
PUSH AX ; save integer part
CALL intreal ; convert -> real
OR.B AL,AL ; zero ?
JZ expzer ; :yes
DEC.B AL ; / 2
expzer XCHG AX,CX ; swap them
XCHG BX,SI
XCHG DX,DI
CALL resub ; subtraction -> frac
MOV DI,#fltexp ; ptr to constants
MOV CX,#$0008 ; 8 numbers
CALL poly2 ; do polynome
POP CX ; get exponent
SHR CX,1 ; / 2
JNB expeven ; :even
PUSH CX ; save it
MOV CX,#$FB81 ; * Sqrt(2)
MOV SI,#$F333
MOV DI,#$3504
CALL remult ; multiplication
POP CX ; restore exponent
expeven ADD.B AL,CL ; add exponents
JB experr ; :overflow error
POPF ; restore sign
JZ exppush ; pos: store result
MOV CX,AX ; negative: do 1/x -> x
MOV SI,BX ; first -> second
MOV DI,DX
MOV AX,#$0081 ; first = 1
XOR BX,BX
XOR DX,DX
CALL rediv ; division
exppush JMP repush ; 'push result
experr POP AX ; clear stack
MOV DL,#$01 ; Floating point overflow
JMP runerr ; "
fltexp W $2E6D,$111D,$3160 ; 1.3215486790E-06 ln(2)**8/8! Constants for Exp
W $4670,$FE2C,$7FE5 ; 1.5252733804E-05 ln(2)**7/7!
W $3674,$897C,$2184 ; 1.5403530393E-04 ln(2)**6/6!
W $5377,$FF3C,$2EC3 ; 1.3333558146E-03 ln(2)**5/5!
W $D27A,$5B7D,$1D95 ; 9.6181291076E-03 ln(2)**4/4!
W $257C,$46B8,$6358 ; 5.5504108665E-02 ln(2)**3/3!
W $167E,$EFFC,$75FD ; 2.4022650696E-01 ln(2)**2/2!
W $D280,$17F7,$3172 ; 6.9314718056E-01 "ln(2)
xarctan POP errpos ; ArcTan: get ret addr
POP AX ; get number
POP BX
POP DX
OR.B AL,AL ; zero ?
JZ exppush ; yes: return
XOR CX,CX ; clear neg flag
TEST.B DH,#$80 ; negative ?
JZ atnpos ; :no
INC CX ; set neg flag
AND.B DH,#$7F ; make positive
atnpos PUSH CX ; save neg flag
MOV CX,#$0081 ; second = 1
XOR SI,SI
XOR DI,DI
CALL recmp ; real comparison
JB atnsmall ; :x < 1
XCHG AX,CX ; swap numbers
XCHG BX,SI
XCHG DX,DI
CALL rediv ; division x -> 1/x
POP CX ; restore neg flag
INC CX ; set bits: large number
INC CX
PUSH CX ; push it again
atnsmallMOV CX,#$4A7E ; > 0.1371 ?
MOV SI,#$E98E
MOV DI,#$0C6F
CALL recmp ; real comparison
JNB atnrng ; :yes
CALL atnpoly ; do polynome
JMP.b atndone ; 'complete result
atnrng MOV DI,#fltatnrg ; pointer into table
MOV CX,#$0002
atnrlp PUSH CX ; save index
PUSH DI ; save ptr
CS: ; test different ranges
MOV CX,[DI] ; get table entry
CS:
MOV SI,[DI]$02
CS:
MOV DI,[DI]$04
CALL recmp ; real comparison
POP DI ; restore
POP CX
JB atnrfnd ; :smaller than that
ADD DI,#$12 ; go to next entry
LOOP atnrlp ; :another one
SUB DI,#$06 ; save space in table
atnrfnd ADD DI,#$06 ; go to associated number
MOV retrc1,AX ; save number
MOV retrc2,BX
MOV retrc3,DX
PUSH DI ; save ptr
CS: ; get number from table
MOV CX,[DI]
CS:
MOV SI,[DI]$02
CS:
MOV DI,[DI]$04
CALL resub2 ; subtraction x-t
PUSH DX ; save number
PUSH BX
PUSH AX
MOV AX,retrc1 ; restore x
MOV BX,retrc2
MOV DX,retrc3
CALL remult ; x*t
MOV CX,#$0081 ; second = 1
XOR SI,SI
XOR DI,DI
CALL readd ; addition
MOV CX,AX ; first -> second
MOV SI,BX
MOV DI,DX
POP AX ; restore x-t
POP BX
POP DX
CALL rediv ; division -> (x-t)/(x*t+1)
CALL atnpoly ; do polynome
POP DI ; restore ptr
ADD DI,#$06
CS:
MOV CX,[DI] ; get number
CS:
MOV SI,[DI]$02
CS:
MOV DI,[DI]$04
CALL readd ; add it
atndone POP CX ; get flag
TEST.B CL,#$02 ; done 1/x ?
JZ atnnorcp ; :no
PUSH CX ; save flag
MOV CX,AX ; first -> second
MOV SI,BX
MOV DI,DX
MOV AX,#$2181 ; first = pi/2
MOV BX,#$DAA2
MOV DX,#$490F
CALL resub ; subtraction pi/2-y
POP CX ; restore flag
atnnorcpTEST.B CL,#$01 ; negative ?
JZ atnpos2 ; :no
OR.B DH,#$80 ; set sign
atnpos2 JMP repush ; "push result
fltatnrgW $E77F,$CCCF,$5413 ; 4.1421356237E-01 1. tan(22.5) range table
W $F67F,$A2F4,$0930 ; 2.6794919243E-01 tan(15) for ArcTan
W $6A7F,$91C1,$060A ; 2.6179938780E-01 15
W $B580,$8A9E,$446F ; 7.6732698798E-01 2. tan(37.5)
W $8280,$3A2C,$13CD ; 5.7735026919E-01 tan(30)
W $6A80,$91C1,$060A ; 5.2359877560E-01 30
W $0081,$0000,$0000 ; 1.0000000000E+00 3. tan(45)
W $2180,$DAA2,$490F ; 7.8539816340E-01 " 45
fltatn W $E87D,$8BA2,$BA2E ; -9.0909090909E-02 -1/11 constants for ArcTan
W $8E7D,$38E3,$638E ; 1.1111111111E-01 1/ 9
W $497E,$2492,$9249 ; -1.4285714286E-01 -1/ 7
W $CD7E,$CCCC,$4CCC ; 2.0000000000E-01 1/ 5
W $AB7F,$AAAA,$AAAA ; -3.3333333333E-01 " 1/ 3
atnpoly MOV DI,#fltatn ; ptr to ArcTan constants
MOV CX,#$0005 ; 5 of them
poly1 PUSH DX ; do polynome: store number
PUSH BX ; y:=x+c*x**3+b*x**5+a*x**7...
PUSH AX
PUSH CX ; save cnt
PUSH DI ; save ptr
MOV CX,AX ; first -> second
MOV SI,BX
MOV DI,DX
CALL remult ; multiplication -> square
POP DI ; restore cnt,ptr
POP CX
CALL poly2 ; do polynome 2
POP CX ; get number -> second
POP SI
POP DI
JMP remult ; "multiplication
poly2 MOV retrc1,AX ; do polynome 2: store number
MOV retrc2,BX ; y:=1+c*x+b*x**2+a*x**3...
MOV retrc3,DX
CS: ; get number from table
MOV AX,[DI]
CS:
MOV BX,[DI]$02
CS:
MOV DX,[DI]$04
PUSH CX ; save ptr, cnt
PUSH DI
JMP.b polystrt ; 'start it
polyloopPUSH CX ; save ptr, cnt
PUSH DI
CS:
MOV CX,[DI] ; get number from table
CS:
MOV SI,[DI]$02
CS:
MOV DI,[DI]$04
CALL readd ; add it
polystrtMOV CX,retrc1 ; get x -> second
MOV SI,retrc2
MOV DI,retrc3
CALL remult ; multiplication *x
POP DI ; restore ptr, cnt
POP CX
ADD DI,#$06 ; go to next number
LOOP polyloop ; :another one
MOV CX,#$0081 ; second = 1
XOR SI,SI
XOR DI,DI
JMP readd ; "add 1
fmtreal PUSH BX ; Format real number
CMP DX,#$19 ; number of fraction chars
JB frnolim2 ; < 25:ok
MOV AX,CX ; field width
CALL limstind ; limit it
MOV DL,#$07
TEST.B [DI]$05,#$80 ; negative (DI:ptr to num)
JZ frpos ; :no
INC.B DL ; one char more
frpos SUB.B AL,DL
JNB frnound ; :no underflow
XOR.B AL,AL ; negative: make zero
frnound CMP AL,#$09 ; limit to 9
JB frnolim
MOV AL,#$09
frnolim INC.B AL ; -> number of fraction chars
MOV.B DL,AL
MOV.B DH,AL
frnolim2PUSH DX ; save # fraction chars
CALL realdec ; convert to decimal
POP DX ; restore
MOV.B AL,DL
INC.B AL ; number of mantissa chars
OR.B DH,DH
JNZ frround
ADD.B AL,CL
JNS frlimprc
MOV.B cvoutbuf,#$00 ; mark end of buffer
JMP.b frfmtit ; '
frlimprcCMP AL,#$0C ; max 11 digits shown
JB frround ; :ok
MOV AL,#$0B ; limit it
frround CALL decround ; round up number
frfmtit POP BX ; dest ptr
MOV SI,#cvoutbuf ; source: dec buffer
TEST.B CH,#$80 ; test sign
JZ frpos2 ; :no
MOV AL,#$2D ; put a -
CALL frdigsto
frpos2 MOV.B CH,CL ; exponent: number of int digs
OR.B DH,DH ; size of number
JZ frzer ; :zero
MOV CH,#$00
frzer OR.B CH,CH ; neg exponent ?
JNS frint ; :no
CALL frdig0 ; store 0 - no int part
JMP.b frfrac0 ; 'do fraction part
frint CALL frdig ; put char from source
DEC.B CH ; another one ?
JNS frint ; :yes
frfrac0 OR.B DL,DL ; test fraction len
JZ frexp ; :nothing
MOV AL,#$2E ; put a .
CALL frdigsto
frfill0 INC.B CH ; put zeroes as necessary
JZ frfrac ; :exponent ok
CALL frdig0 ; put a 0
DEC.B DL ; field filled ?
JNZ frfill0 ; :no
frfrac DEC.B DL ; another fraction digit ?
JS frexp ; :no
CALL frdig ; do digit
JMP frfrac ; 'next one
frexp OR.B DH,DH ; do exponent ?
JNZ frputexp ; :yes
RET ; '
frputexpMOV AL,#$45 ; put an E
CALL frdigsto
MOV AL,#$2B ; +
OR.B CL,CL ; test sign
JNS frposexp ; :positive
NEG.B CL ; negate exponent
MOV AL,#$2D ; -
frposexpCALL frdigsto ; store sign
MOV AL,#$2F ; do DIV 10 / MOD 10
frexpsubINC.B AL ; count up digit
SUB.B CL,#$0A ; successive subtraction
JNB frexpsub ; :continue
CALL frdigsto ; put digit
ADD.B CL,#$3A ; restore second digit
MOV.B AL,CL ; put digit
JMP.b frdigsto ; "
frdig MOV.B AL,[SI] ; get digit from source
OR.B AL,AL ; end ?
JZ frdig0 ; :yes
INC SI ; ptr to next char
JMP.b frdigsto ; 'store digit
frdig0 MOV AL,#$30 ; store a 0
frdigstoMOV.B [BX],AL ; store digit
INC BX ; ptr to next dest char
RET ; "
realdec MOV AX,[DI] ; Real -> Decimal
MOV BX,[DI]$02 ; get real number (in CS !)
MOV DX,[DI]$04
OR.B AL,AL ; zero ?
JNZ rdno0 ; :no
MOV SI,#cvoutbuf ; fill buffer with zeroes
rdfill MOV [SI],#$3030
INC SI
INC SI
CMP SI,#currfil ; end reached ?
JNZ rdfill ; :no
MOV CX,#$0000 ; exponent 0
RET ; '
rdno0 MOV.B CH,DH ; get sign
AND.B DH,#$7F ; clear sign in mantissa
PUSH AX ; save exp
PUSH DX ; save mantissa
SUB AL,#$80 ; exponent
CBW
MOV DX,#$004D ; * 77
IMUL DX ; 77/256 is about ln(2)/ln(10) !
ADD AX,#$0005 ; +5
MOV.B CL,AH ; this is approx. dec exponent
POP DX ; restore
POP AX
CMP.B CL,#$D9 ; correct error
JNZ rdnocomp ; :ok
INC.B CL
rdnocompPUSH CX ; save exponent, sign
NEG.B CL ; negate exponent
CALL realrang ; bring into range
POP CX ; restore
CMP AL,#$81 ; exp ok ?
JNB rdnoadj ; :yes
CALL mult10 ; mult * 10
DEC.B CL ; count down dec exp
rdnoadj PUSH CX ; save exp, sign
OR.B DH,#$80 ; set mantissa MSB
MOV CL,#$84 ; offset for exponent
SUB.B CL,AL
MOV AL,#$00 ; LSB = 0
JZ rdnosh ; :no shift
rdshift SHR DX,1 ; convert to 6-byte-card
RCR BX,1
RCR AX,1
DEC.B CL ; shift again ?
JNZ rdshift ; :yes
rdnosh MOV SI,#cvoutbuf ; ptr to output buffer
rdconv MOV.B CH,DH ; get upper 4 bits
MOV CL,#$04
SHR.B CH,CL
ADD.B CH,#$30 ; -> digit
MOV.B [SI],CH ; store digit
AND.B DH,#$0F ; clear that digit
PUSH DX ; card * 10 -> card
PUSH BX ; save number
PUSH AX
SHL AX,1 ; card * 4
RCL BX,1
RCL DX,1
SHL AX,1
RCL BX,1
RCL DX,1
POP CX ; + card
ADD AX,CX
POP CX
ADC BX,CX
POP CX
ADC DX,CX
SHL AX,1 ; * 2 = card * 10
RCL BX,1
RCL DX,1
INC SI ; next buffer pos
CMP SI,#currfil ; done ?
JNZ rdconv ; :no
POP CX ; restore exp, sign
RET ; "
decroundXOR.B AH,AH ; Round up decimal number
MOV BX,#cvoutbuf ; ptr to buffer
ADD BX,AX ; add digit index
CMP.B [BX],#$35 ; 5 ?
MOV.B [BX],#$00 ; store 0: end mark
JB drdone ; below: no round up
drloop DEC.B AL ; go back one digit
JS drincexp ; :beg of buffer reached
DEC BX ; go back one pos
INC.B [BX] ; inc that digit
CMP.B [BX],#$3A ; carry ?
JB drdone ; no: done
MOV.B [BX],#$00 ; mark as end
JMP drloop ; 'continue
drincexpMOV.B [BX],#$31 ; store a 1
MOV.B [BX]$01,#$00 ; end mark
INC.B CL ; inc exponent
drdone RET ; "
ascreal MOV.B CL,[BX] ; String -> Real
CMP.B CL,#$2D ; - ?
JNZ arpos ; :no
INC BX ; next char
arpos PUSH CX ; save sign
CALL ascreal2 ; convert unsigned real
POP CX ; restore sign
JB arerr ; :error
CMP.B CL,#$2D ; - ?
JNZ arpos1 ; :no
CMP.B [DI],#$00 ; result = 0 ?
JZ arpos1
XOR.B [DI]$05,#$80 ; negate it
arpos1 CLC ; no error
arerr RET ; "
ascreal2MOV SI,BX ; source ptr
XOR AX,AX ; ASCII -> unsigned real
XOR BX,BX ; clear result
XOR DX,DX
XOR CX,CX
MOV.B cvexpcnt,#$00 ; exponent
arloop MOV.B CL,[SI] ; get char
CMP.B CL,#$61 ; lower case ?
JB arupc ; :no
CMP.B CL,#$7A
JA arupc ; :no
SUB.B CL,#$20 ; convert to upper case
arupc CALL ardigit2 ; do a digit
JB arnodig ; :no digit
CALL mult10 ; result * 10
JB arover ; :overflow
PUSH DI ; save ptrs
PUSH SI
PUSH CX
PUSH DX ; save result
PUSH BX
PUSH AX
MOV.B AL,CL ; get digit
XOR.B AH,AH ; clear hi byte
CALL intreal ; convert to real
POP CX ; restore result
POP SI
POP DI
CALL readd ; add digit to result
POP CX ; restore ptrs
POP SI
POP DI
TEST.B CH,#$40 ; after decimal point ?
JZ arnext ; :yes
DEC.B cvexpcnt ; count down exponent
JMP.b arnext ; 'next digit
arnodig CMP.B CL,#$2E ; decimal point ?
JNZ arexp ; :no, test exponent
TEST.B CH,#$40 ; . already done ?
STC ; error
JNZ arover ; yes: error
OR.B CH,#$40 ; set flag
arnext INC SI ; next char
JMP arloop ; 'continue
arover MOV BX,SI ; pointer: end pos
RET ; '
arexp CMP.B CL,#$45 ; E ?
MOV.B CL,cvexpcnt ; exponent
JNZ arexp3 ; :no
CALL realrng ; bring into range
JB arover ; :error
INC SI ; go to next char
MOV.B CL,[SI] ; get it
CMP.B CL,#$2B ; + ?
JZ arposexp ; :yes
CMP.B CL,#$2D ; - ?
JNZ arexp2 ; no: digit
OR.B CH,#$20 ; set flag: neg exponent
arposexpINC SI ; next char
arexp2 CALL ardigit ; do digit
JB arover ; :error
PUSH AX ; save
MOV.B AL,CL ; first digit
INC SI ; next char
CALL ardigit ; do digit
JB aronedig ; :no second digit
MOV.B AH,AL ; AL*10 -> AL
SHL.B AL,1
SHL.B AL,1
ADD.B AL,AH
SHL.B AL,1
ADD.B AL,CL
INC SI ; next char
aronedigMOV.B CL,AL ; new exponent
POP AX ; restore
TEST.B CH,#$20 ; negative exponent ?
JZ arexp3 ; :no
NEG.B CL ; negate it
arexp3 CALL realrng ; real number*10**exp
MOV [DI],AX ; store the result
MOV [DI]$02,BX
MOV [DI]$04,DX
JMP arover ; "set pointer to end
realrng CMP.B CL,#$DA ; outside a reasonable range ?
JL rrerr ; :yes
CMP.B CL,#$26
JG rrerr ; :yes
PUSH CX ; save pointers
PUSH SI
PUSH DI
CALL realrang ; bring into range
POP DI
POP SI
POP CX
RET ; '
rrerr STC ; error
RET ; "
ardigit MOV.B CL,[SI] ; get digit
ardigit2CMP.B CL,#$30 ; < 0 ?
JB ardret ; :yes
CMP.B CL,#$3A ; > 9 ?
CMC ; change to error flag
JB ardret ; :yes
SUB.B CL,#$30 ; convert to number
ardret RET ; "
realrangPUSH DX ; bring into range:
PUSH BX ; number*10**CL
PUSH AX ; save number
MOV.B cvdecexp,CL ; save exponent
OR.B CL,CL ; negative ?
JNS rrpos ; :no
NEG.B CL ; make it positive
rrpos MOV.B BL,CL ; (exponent DIV 4)*6
AND.B BL,#$FC
MOV.B BH,BL
SHR.B BL,1
ADD.B BL,BH ; -> pointer into table
XOR.B BH,BH ; clear hi
LEA DI,[BX]fltdec ; factor table
CS:
MOV AX,[DI] ; get factor
CS:
MOV BX,[DI]$02
CS:
MOV DX,[DI]$04
AND.B CL,#$03 ; exponent MOD 4
JZ rrdone ; :ok
rrmul CALL mult10 ; do successive multiplications
DEC.B CL ; another ?
JNZ rrmul ; :yes
rrdone MOV CX,AX ; factor -> second
MOV SI,BX
MOV DI,DX
POP AX ; restore number
POP BX
POP DX
TEST.B cvdecexp,#$80 ; positive exponent ?
JNZ rrdiv ; :no
JMP remult ; 'multiply num*factor
rrdiv JMP rediv ; "divide num/factor
fltdec W $0081,$0000,$0000 ; 1.0000000000E+00 decimal factor table
W $008E,$0000,$1C40 ; 1.0000000000E+04
W $009B,$2000,$3EBC ; 1.0000000000E+08
W $00A8,$A510,$68D4 ; 1.0000000000E+12
W $04B6,$C9BF,$0E1B ; 1.0000000000E+16
W $ACC3,$EBC5,$2D78 ; 1.0000000000E+20
W $CDD0,$1BCE,$53C2 ; 1.0000000000E+24
W $F9DE,$3978,$013F ; 1.0000000000E+28
W $2BEB,$ADA8,$1DC5 ; 1.0000000000E+32
W $C9F8,$CE7B,$4097 ; 1.0000000000E+36 "
mult10 OR.B AL,AL ; Real multiplication * 10
JNZ m10not0 ; :not zero
RET ; 'zero - return
m10not0 OR.B DH,#$80 ; set mantissa MSB
PUSH CX ; save CX
PUSH DX ; save number
PUSH BX
PUSH AX
SHR DX,1 ; mantissa / 4
RCR BX,1
RCR.B AH,1
SHR DX,1
RCR BX,1
RCR.B AH,1
POP CX ; add mantissa
ADD.B AH,CH ; why no ADC (rounding !) ?
POP CX
ADC BX,CX
POP CX
ADC DX,CX
POP CX ; restore CX
JNB m10nrm
RCR DX,1 ; shift right
RCR BX,1
RCR.B AH,1
INC.B AL ; exponent+1
JNZ m10nrm ; :ok
STC ; overflow...
RET ; '
m10nrm AND.B DH,#$7F ; make positive
ADD AL,#$03 ; exponent+3
RET ; "
realcardPOP SI ; Real -> long cardinal
POP DI ; 2 ret addrs
POP DX ; get real
POP CX
POP BX
PUSH DI ; restore rets
PUSH SI
TEST.B BH,#$80 ; negative ?
JNZ rczero ; yes:return zero
OR.B BH,#$80 ; set mantissa MSB
MOV AL,#$A0 ; exponent offset
SUB.B AL,DL ; calc number of shifts
JB rcover ; :too much
CMP AL,#$20 ; too small ?
JNB rczero ; :return zero
rcdenormOR.B AL,AL ; another shift ?
JZ rcdone ; :done
SHR BX,1 ; shift right: denormalize
RCR CX,1
DEC.B AL
JMP rcdenorm ; 'next one
rcdone MOV AX,CX ; return number in DX:AX
MOV DX,BX
RET ; '
rczero XOR AX,AX ; return zero
XOR DX,DX
RET ; '
rcover MOV AX,#$FFFF ; return maxcard
MOV DX,#$FFFF
RET ; "
cardrealMOV BX,DX ; long cardinal -> real
MOV CX,AX
OR AX,DX ; 0 ?
JZ crzero ; yes: return 0
MOV DX,#$00A0 ; exponent, LSB mantissa
crnorm TEST.B BH,#$80 ; normalized ?
JNZ crstore ; :yes
SHL CX,1 ; shift left
RCL BX,1
DEC.B DL ; count down exponent
JMP crnorm ; 'continue
crstore AND.B BH,#$7F ; make positive
crzero POP AX ; return addr
PUSH BX ; push result
PUSH CX
PUSH DX
JMP AX ; "return
xassgntxMOV AL,#$01 ; text file
doassignMOV filfunc,AL ; do assign: store func code
POP BX ; ret addr
CALL getpn ; string -> ASCIIZ
POP DI ; ptr to file var
POP ES
PUSH BX ; restore ret
MOV AX,ES ; file var in DS ?
MOV DX,DS
CMP AX,DX
JNZ asnostd
CMP DI,#stdout ; std in / out file ?
JBE asgnerr ; :yes, error
asnostd PUSH DI ; save var ofs
MOV SI,#pnbuf ; path name buffer
LEA DI,[DI]$0C ; path name in file var
MOV CX,#$0020 ; copy 64 chars
CLD
REPZ
MOVS ; do it
POP DI ; restore file var ofs
CALL devtest ; test if device
JNB asnodev ; :yes
MOV AL,#$00 ; flag: not open
MOV BX,#$FFFF ; no handle
asnodev ES:
MOV [DI],BX ; store file handle
CMP.B filfunc,#$00 ; text file ?
JZ asnotxt ; :no
ES:
MOV.B [DI]$02,AL ; set file flag
LEA AX,[DI]$4C ; set buffer ofs
ES:
MOV [DI]$04,AX ; store in file var
RET ; '
asnotxt ES: ; set file var:
MOV [DI]$02,#$0000 ; record length
RET ; '
asgnerr MOV.B errnum,#$22 ; Assign to std files
RET ; "not allowed
xresettxXOR.B AL,AL ; Reset text file
JMP.b opentxt ; '
xrewrttxMOV AL,#$01 ; Rewrite text file
JMP.b opentxt ; '
xappndtxMOV AL,#$02 ; Append text file
opentxt MOV filfunc,AL ; store function code
POP errpos ; get ret addr
POP ES ; file var ptr
PUSH errpos ; restore ret
ES:
MOV.B AL,[DI]$02 ; test flag
AND AL,#$0F ; device ?
JZ otnodev ; :no
ES:
AND.B [DI]$02,#$DF ; clear flag: char preread
otret RET ; '
otnodev ES:
MOV [DI]$06,CX ; store buffer size
CALL close1 ; close file
CMP.B errnum,#$00 ; error ?
JNZ otret ; yes:ret
CALL openfile ; do open file
CMP.B errnum,#$00 ; error ?
JNZ otret ; yes:ret
TEST modeflg,#$0002 ; do device checking ?
JZ otnodev2 ; :no
MOV AX,#$4400 ; test device status
ES:
MOV BX,[DI] ; get file handle
CALL dos ; do it
TEST DX,#$0080 ; device ?
JZ otnodev2 ; :no
ES:
MOV [DI]$06,#$0001 ; buffer len: 1 char
otnodev2CMP.B filfunc,#$01 ; read ?
JNB otappend ; :no
ES:
MOV.B [DI]$02,#$80 ; open for input
ES:
MOV BX,[DI]$04 ; buffer pos
ES:
MOV [DI]$08,BX ; -> buffer ptr
ES:
MOV [DI]$0A,BX ; -> buffer end
RET ; '
otappendJZ prepout ; write: prepare for output
MOV AX,#$4202 ; seek relative to EOF
ES:
MOV BX,[DI] ; file handle
XOR CX,CX ; offset 0
XOR DX,DX
CALL dos ; do it: get file length
ES:
MOV CX,[DI]$06 ; buffer size
CMP CX,#$0080 ; < 128 ?
JB otsmall ; yes: ok
MOV CX,#$0080 ; go back up to 128 bytes
otsmall SUB AX,CX ; sub from file pos
SBB DX,#$00
JNB otnotbeg ; :ok
ADD AX,CX ; beyond beg of file -
MOV CX,AX ; go to beg of file
XOR AX,AX
XOR DX,DX
otnotbegPUSH CX ; save char count
MOV CX,DX ; dest pos
MOV DX,AX
MOV AX,#$4200 ; seek absolute
ES:
MOV BX,[DI] ; file handle
CALL dos ; do seek
CALL gbrdbuf ; read from buffer
POP DX ; counter
NEG DX
ES:
MOV SI,[DI]$08 ; buffer ptr
otsearchES:
CMP.B [SI],#$1A ; search ^Z
JZ oteof ; :found
INC SI ; next char
INC DX
JNZ otsearch ; :continue
JMP.b prepout ; 'EOF not found
oteof MOV AX,#$4202 ; seek from end
ES: ; DX = offset from end
MOV BX,[DI] ; file handle
MOV CX,#$FFFF ; backwards
CALL dos ; do seek
prepout ES: ; prepare for subsequent output
MOV.B [DI]$02,#$40 ; open for output
ES:
MOV AX,[DI]$04 ; buffer offset
ES:
MOV [DI]$08,AX ; -> buffer ptr
ES:
ADD AX,[DI]$06 ; + buffer size
ES:
MOV [DI]$0A,AX ; -> buffer end
poret RET ; "
xtrunctxPOP errpos ; Truncate text file
POP ES ; file var ptr
PUSH errpos ; restore ret
ES:
CMP.B [DI]$02,#$80 ; open for input ?
JNZ poret ; :no - ret
ES:
MOV DX,[DI]$08 ; buffer ptr
ES:
SUB DX,[DI]$0A ; - buffer end
JZ trend ; equal: ok
MOV AX,#$4201 ; seek relative
ES:
MOV BX,[DI] ; file handle
MOV CX,#$FFFF ; backwards
CALL dos ; do it
trend MOV AH,#$40 ; write
ES:
MOV BX,[DI] ; file handle
XOR CX,CX ; len = 0 -> truncate
CALL dos ; do it
JMP prepout ; "prepare for output
xflush POP errpos ; Flush
POP ES ; file var ptr
PUSH errpos ; restore ret
flush ES:
CMP.B [DI]$02,#$40 ; output file ?
JNZ flushret ; no: ret
JMP pbflush ; 'flush buffer
flushretRET ; "
xclosetxPOP errpos ; Close text file
POP ES ; get file var pt
PUSH errpos ; restore ret
close1 ES:
MOV.B AL,[DI]$02 ; get flags
AND AL,#$0F ; device ?
JNZ closeret ; yes: ret
CALL flush ; flush the buffer
ES:
MOV.B [DI]$02,#$00 ; clear flag
close2 ES:
MOV BX,[DI] ; file handle
CMP BX,#$02 ; standard file ?
JBE closeret ; :ret
CMP BX,#-$01 ; not open ?
JZ closeret ; yes:ret
ES:
MOV [DI],#$FFFF ; clear file handle
MOV AH,#$3E ; close file
CALL dos ; do it
JNB closeret ; :ok, no error
MOV.B errnum,#$FF ; file disappeared
closeretRET ; "
devtest MOV CX,#$0009 ; Test filename for device
MOV BX,#devtable
devloop PUSH CX ; save cnt, ptr
PUSH BX
MOV SI,#pnbuf ; file name
MOV CX,#$0003 ; 3 chars
devcloopMOV.B AL,[SI] ; get char
CALL upcase ; ignore upper / lower
CS:
CMP.B AL,[BX] ; compare
JZ devnextc ; :ok
POP BX ; restore cnt, ptr
POP CX
ADD BX,#$06 ; next device
LOOP devloop ; another one ?
devnone STC ; not found
RET ; '
devnextcINC SI ; next char
INC BX
LOOP devcloop ; :another char
POP CX ; remove
POP CX
CMP.B [SI],#$3A ; next char = : ?
JNZ devnone ; :no device
CS:
MOV.B AL,[BX] ; get flag
CS:
MOV BX,[BX]$01 ; get file handle
RET ; "
devtableB "CON" ; Device table
B $C1,$FF,$FF ; input, output, dev 1
B "TRM"
B $C1,$FF,$FF ; input, output, dev 1
B "KBD"
B $82,$FF,$FF ; input, dev 2
B "LST"
B $43,$FF,$FF ; output, dev 3
B "AUX"
B $C4,$FF,$FF ; input, output, dev 4
B "USR"
B $C5,$FF,$FF ; input, output, dev 5
B "INP" ; std MS-DOS input-file
B $00,$00,$00 ; not open, handle 0
B "OUT" ; std MS-DOS output-file
B $00,$01,$00 ; not open, handle 1
B "ERR" ; std MS-DOS error file
B $00,$02,$00 ; "not open, handle 2
openfileES: ; do open file
CMP [DI],#-$01 ; handle <> $ffff ?
JNZ opret ; yes: already open
MOV AX,#$3D02 ; open for input / output
MOV DL,#$01 ; error number
TEST.B filfunc,#$01 ; create file ?
JZ opnotnew ; :no
MOV AH,#$3C ; create
XOR CX,CX ; clear attribute
MOV DL,#$F1 ; error (dir full)
opnotnewPUSH DX ; save error number
LEA DX,[DI]$0C ; ptr to path name
CALL dos ; do it
POP DX ; restore error number
JB operr ; :error
ES:
MOV [DI],AX ; store file handle
RET ; '
operr MOV.B errnum,DL ; store error number
CMP AL,#$04 ; too many open files ?
JNZ opret ; :no
MOV.B errnum,#$F3 ; set that error
opret RET ; "
xstdin POP errpos ; Set standard input
MOV currfil,#stdin ; ptr to file var
MOV currfil1,DS
JMP [errpos] ; "return - error pos set
xrdfil POP errpos ; prepare for read
POP ES ; get file var ptr
MOV currfil,DI ; -> current file
MOV currfil1,ES
ES:
TEST.B [DI]$02,#$80 ; open for input ?
JNZ prret ; :yes
MOV.B errnum,#$02 ; error: not open for input
prret JMP [errpos] ; "return
xstdout POP errpos ; Set standard output
MOV currfil,#stdout ; ptr to file var
MOV currfil1,DS
JMP [errpos] ; "return
xwrfil POP errpos ; prepare for write
POP ES ; get file var ptr
MOV currfil,DI ; -> current file
MOV currfil1,ES
ES:
TEST.B [DI]$02,#$40 ; open for output ?
JNZ pwret ; :no
MOV.B errnum,#$03 ; error: not open for output
pwret JMP [errpos] ; "return
xrd MOV AL,#$FF ; Readln string
JMP.b readst ; '
xrdln XOR.B AL,AL ; Read string
readst POP errpos ; get ret addr
MOV currfil,#stdin ; from std input
MOV currfil1,DS
AND.B stdinfl,#$DF ; clear flag: char read
PUSH ES ; save dest var ptr
PUSH DI
PUSH AX ; save flag
CALL rdedit ; read with editing
POP AX ; restore flag
OR.B AL,AL ; readln ?
JZ readst2 ; :no
CALL xwriteln ; do WriteLn
readst2 POP DI ; restore dest var ptr
POP ES
JMP [errpos] ; "return
rdedit XOR.B DH,DH ; Read line with editing: clr flag
rdedit2 MOV.B CH,conbufln ; buffer length
CMP.B CH,#$7E ; too big ?
JB relimlen ; :no
MOV CH,#$7E ; limit to 127 chars
relimlenMOV.B conbufln,#$7E ; 127 chars again
MOV BX,#coninbuf
MOV conbufpt,BX ; set input ptr
rezero XOR.B CL,CL ; ptr into line
reloop CALL keyget ; get char
MOV DL,#$01 ; flag: one char
CMP AL,#$08 ; BS ?
JZ rebs ; :yes
CMP AL,#$7F ; Delete ?
JZ rebs ; :yes
CMP AL,#$04 ; ^D ?
JZ recall ; yes, recall char from buffer
DEC.B DL ; flag: all chars
CMP AL,#$18 ; ^X ?
JZ rebs ; yes:erase input line
CMP AL,#$1B ; ESC ?
JZ rebs ; yes:erase input line
CMP AL,#$12 ; ^R ?
JZ recall ; yes:recall last input line
CMP AL,#$1A ; ^Z ?
JZ reeof ; :yes
CMP AL,#$0D ; CR ?
JZ recr ; :yes
CMP AL,#$20 ; other control char ?
JB reloop ; yes: ignore
CMP.B CL,CH ; end of buffer reached ?
JZ reloop
MOV.B AH,[BX] ; get old char
MOV.B [BX],AL ; store new char
INC.B CL ; new pos
INC BX
CMP.B AH,#$20 ; was it old end of buffer ?
JNB renotend ; :no
MOV.B [BX],AH ; mark it again
renotendCALL xputch ; display new char
JMP reloop ; 'next key
rebs DEC.B CL ; go back one char
JS rezero ; :beg of line
CALL prints ; go back one char
B $08," ",$08,$00
DEC BX ; go back
DEC.B DL ; another char ?
JNZ rebs ; :yes
JMP reloop ; 'next key
recall MOV.B AL,[BX] ; recall from buffer
CMP AL,#$20 ; end of buffer
JB reloop ; :yes
CALL xputch ; display that char
INC.B CL ; next one
INC BX
DEC.B DL ; another one ?
JNZ recall ; :yes
JMP reloop ; 'next key
reeof OR.B DH,DH ; test flag
JZ reloop ; :no EOF allowed
JMP.b resto ; 'store it
recr OR.B DH,DH ; test flag
JNZ reend ; :no ^Z needed
resto MOV.B [BX],#$1A ; store ^Z
JMP.b reend2 ; 'end it
reend CALL xwriteln ; WriteLn
MOV [BX],#$0A0D ; store CR,LF at end
INC BX ; 2 chars added
reend2 INC BX ; 1 char added
MOV conbfend,BX ; store end pointer
RET ; "
xputch MOV.B AH,cbreak ; Put char: save break flag
MOV.B cbreak,#$00 ; break allowed
PUSH AX ; save flag
CALL conput ; print char
POP AX ; restore flag
MOV.B cbreak,AH
RET ; "
getbyte LES DI,currfil ; Get byte from current file
getbyte2CMP.B errnum,#$00 ; error ?
JNZ gbeof ; yes: return ^Z
ES:
MOV.B AL,[DI]$02 ; test flags:
TEST AL,#$20 ; char pre-read ?
JNZ gbfrbuf ; yes: return it
AND AL,#$0F ; device ?
JNZ gbdev ; :yes
ES:
MOV BX,[DI]$08 ; buffer pointer
ES:
CMP BX,[DI]$0A ; = buffer end ?
JB gbnotend ; :no
CALL gbrdbuf ; read buffer
ES:
MOV BX,[DI]$08 ; buffer ptr
gbnotendES:
MOV.B AL,[BX] ; get byte
INC BX ; advance ptr
ES:
MOV [DI]$08,BX ; store ptr
JMP.b gbbuf2 ; 'remember that char
gbdev PUSH ES ; save file ptr
PUSH DI ; test devices
CMP AL,#$01 ; CON ?
JNZ gbkbd ; :no
MOV BX,conbufpt ; get from CON input buffer
CMP BX,conbfend ; end of buffer reached ?
JB gbget ; no: return char
MOV.B DH,AL ; ^Z allowed
CALL rdedit2 ; read line
MOV BX,conbufpt ; ptr to char
gbget MOV.B AL,[BX] ; get char
INC BX ; advance ptr
MOV conbufpt,BX ; update ptr
JMP.b gbbuf ; 'done
gbkbd CMP AL,#$02 ; KBD ?
JNZ gbaux ; :no
DEC SP ; (function:char)
CALL [vkbdget] ; get char
JMP.b gbbuf ; 'return it
gbaux CMP AL,#$04 ; AUX ?
JNZ gbusr ; :no
DEC SP
CALL [vauxget] ; get char
JMP.b gbbuf ; 'return it
gbusr DEC SP ; USR
CALL [vusrget] ; get char
gbbuf POP DI ; restore file var ptr
POP ES
gbbuf2 ES:
MOV.B [DI]$03,AL ; store char in buffer
ES:
OR.B [DI]$02,#$20 ; set flag: char pre-read
RET ; '
gbfrbuf ES:
MOV.B AL,[DI]$03 ; get char from buffer
RET ; '
gbeof MOV AL,#$1A ; return ^Z = EOF
RET ; '
gbrdbuf MOV AH,#$3F ; read buffer
ES:
MOV BX,[DI] ; file handle
ES:
MOV CX,[DI]$06 ; buffer size
ES:
MOV DX,[DI]$04 ; buffer offset
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
CALL dos ; do it
POP DS ; restore DS
JNB gbnoerr ; :no error
XOR AX,AX ; nothing read
gbnoerr ES:
MOV BX,[DI]$04 ; buffer offset
OR AX,AX ; anything read ?
JNZ gbmakeof ; :yes
ES:
MOV.B [BX],#$1A ; store a ^Z
INC AX ; 1 char read
gbmakeofES:
MOV [DI]$08,BX ; -> buffer pointer
ADD BX,AX ; + number chars read
ES:
MOV [DI]$0A,BX ; -> buffer end
RET ; "
readnum PUSH ES ; Read number
PUSH DI ; save ptr
MOV BX,#pnbuf ; buffer ptr
rnspace PUSH BX ; save
CALL getbyte ; get char
POP BX ; restore ptr
CMP AL,#$1A ; ^Z ?
JZ rnend ; yes: end
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
CMP AL,#$20 ; space / control ?
JBE rnspace ; yes: ignore
rndig MOV.B [BX],AL ; store that char
INC BX ; advance ptr
CMP BX,#pnbufend ; end reached ?
JZ rnend ; :yes
PUSH BX ; save ptr
CALL getbyte ; get char
POP BX ; restore ptr
CMP AL,#$20 ; space / control ?
JBE rnend ; yes: end
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
JMP rndig ; 'next digit
rnend MOV.B [BX],#$00 ; store a 0 at the end
MOV BX,#pnbuf ; nothing entered ?
CMP.B [BX],#$00
POP DI ; restore ptr
POP ES
RET ; "
chknum JB cnerr ; Check numeric format
CMP.B [BX],#$00 ; end reached ?
JZ cnret ; yes: ok
cnerr MOV.B errnum,#$10 ; Error in numeric format
STC
cnret RET ; "
xrdchar PUSH DI ; Read char: save ptr
CALL getbyte ; get char
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
POP DI ; var ofs
POP BX ; ret addr
POP ES ; var seg
ES:
MOV.B [DI],AL ; store char
JMP BX ; "return
xrdbyte CLC ; Read byte
JMP.b rdi1 ; '
xrdint STC ; Read integer
rdi1 POP BX ; ret addr
POP ES ; dest seg
PUSH BX ; restore ret
PUSHF ; save flag
CALL readnum ; read number.
JZ rdierr ; :nothing entered
CALL ascint ; convert to integer
CALL chknum ; check numeric format
JB rdierr ; :error
POPF ; restore flag
JNB rdibyt ; :byte
ES:
MOV [DI],AX ; store integer
RET ; '
rdibyt ES:
MOV.B [DI],AL ; store byte
RET ; '
rdierr POPF ; remove flag
RET ; "error - don't change var
xrdreal POP BX ; Read real
POP ES ; dest seg
PUSH BX ; restore ret
CALL readnum ; read number
JZ rdrret ; :nothing entered
PUSH DI ; save dest ptr
PUSH ES
MOV DI,#prnum ; dest var
CALL ascreal ; convert to real
MOV SI,DI ; -> source ptr
POP ES ; restore dest ptr
POP DI
CALL chknum ; check numeric format
JB rdrret ; :error
CLD ; store real number
MOVS
MOVS
MOVS
rdrret RET ; "
xrdstr POP BX ; Read string var
POP ES ; dest seg
PUSH BX ; restore ret
XOR BX,BX ; clear length of string
XOR.B CH,CH ; count. CL=max len
rdsloop PUSH ES ; save dest ptr
PUSH DI
PUSH BX ; save len, cnt
PUSH CX
CALL getbyte ; get char
POP CX ; restore
POP BX
CMP AL,#$0D ; CR ?
JZ rdsend ; :end
CMP AL,#$1A ; ^Z ?
JZ rdsend ; :end
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
POP DI ; restore dest ptr
POP ES
INC BX ; count len
ES:
MOV.B [BX_DI],AL ; store char
LOOP rdsloop ; :another char
JMP.b rdslen ; 'store length
rdsend POP DI ; restore dest ptr
POP ES
rdslen ES:
MOV.B [DI],BL ; store length
RET ; "
xrdarrchPOP BX ; Read array of char
POP ES ; dest ptr
PUSH BX ; restore ret
XOR.B CH,CH ; CL=max len
rdacloopPUSH ES ; save dest ptr
PUSH DI
PUSH CX ; save cnt
CALL getbyte ; get a char
POP CX ; restore cnt
CLD
CMP AL,#$0D ; CR ?
JZ rdacend ; yes: end
CMP AL,#$1A ; ^Z ?
JZ rdacend ; :yes
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
POP DI ; restore dest ptr
POP ES
STOS.B ; store char
LOOP rdacloop ; :another char
RET ; '
rdacend POP DI ; restore dest ptr
POP ES
MOV AL,#$20 ; pad with spaces
REPZ
STOS.B
RET ; "
xreadln CALL getbyte ; Readln: get char
CMP AL,#$1A ; ^Z ?
JZ rdlnret ; yes: done
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
CMP AL,#$0A ; LF ?
JZ rdlnret ; yes: done
CMP AL,#$0D ; CR ?
JNZ xreadln ; no: continue
CALL getbyte ; get next char
CMP AL,#$0A ; LF ?
JNZ rdlnret ; no: forget it
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
rdlnret RET ; "
putbyte LES DI,currfil ; put char to current file
CMP.B errnum,#$00 ; error ?
JNZ pbret ; yes: no output
ES:
MOV.B CL,[DI]$02 ; get flag
AND.B CL,#$0F ; device ?
JNZ pbdev ; :yes
ES:
MOV BX,[DI]$08 ; get buffer pointer
ES:
MOV.B [BX],AL ; store char
INC BX ; advance pointer
ES:
MOV [DI]$08,BX ; update pointer
ES:
CMP BX,[DI]$0A ; = buffer end ?
JZ pbflush ; yes: do flush
RET ; '
pbdev PUSH AX ; put char as parameter
CMP.B CL,#$01 ; CON ?
JZ pbcon ; :yes
CMP.B CL,#$03 ; LST ?
JZ pblst ; :yes
CMP.B CL,#$04 ; AUX ?
JZ pbaux ; :yes
CALL [vusrput] ; USR out
RET ; '
pbcon CALL [vconput] ; CON out
RET ; '
pblst CALL [vprnput] ; LST out
RET ; '
pbaux CALL [vauxput] ; AUX out
pbret RET ; '
pbflush ES: ; flush output buffer
MOV CX,[DI]$08 ; count=pointer-offset
ES:
SUB CX,[DI]$04
JZ pbok ; :nothing to write
MOV AH,#$40 ; write byte block
ES:
MOV BX,[DI] ; file handle
ES:
MOV DX,[DI]$04 ; buffer offset
ES:
MOV [DI]$08,DX ; reset buffer pointer
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
CALL dos ; do it
POP DS ; restore DS
JB pberr ; :error
CMP AX,CX ; length = expected ?
JZ pbok ; :yes
pberr MOV.B errnum,#$F0 ; Disk write error
pbok RET ; "
xwrchar OR AX,AX ; Write char
JZ wchdoit ; AX=formatting parm: nothing
CALL limstind ; limit it
CMP AL,#$01 ; <= 1 char ?
JBE wchdoit
XCHG AX,CX ; -> count
DEC CX ; -1 for char itself
wchpad MOV AL,#$20 ; put spaces
PUSH CX ; save count
CALL putbyte ; put it
POP CX ; restore count
LOOP wchpad ; :continue
wchdoit POP BX ; ret addr
POP AX ; get char
PUSH BX ; restore ret
JMP putbyte ; "put that char
xwrint XCHG AX,CX ; Write integer: format parm
POP BX ; return addr
POP AX ; get number
PUSH BX ; restore ret
PUSH CX ; save format parm
MOV BX,#pnbuf ; dest buffer
CALL intasc ; Integer -> ASCII
wintbuf POP AX ; restore format parm
CALL limstind ; limit it
SUB BX,#pnbuf ; calc length
SUB AX,BX ; length of spaces ?
JBE wintdoit ; :no space left
XCHG AX,CX ; -> count
PUSH BX ; save number length
wintpad MOV AL,#$20 ; put spaces
PUSH CX ; save count
CALL putbyte ; put it
POP CX ; restore count
LOOP wintpad ; :another space
POP BX ; restore number length
wintdoitMOV CX,BX ; -> count
MOV BX,#pnbuf ; buffer ptr
wintloopMOV.B AL,[BX] ; get char
PUSH BX ; save ptr, cnt
PUSH CX
CALL putbyte ; put it
POP CX ; restore
POP BX
INC BX ; next char
LOOP wintloop ; :again
RET ; "
xwrreal XCHG AX,DX ; Write real: second format parm
POP BX ; ret addr
POP CX ; first format parm
MOV DI,#prnum ; get number from stack
POP [DI]
POP [DI]$02
POP [DI]$04
PUSH BX ; restore ret
PUSH CX ; push format parm
MOV BX,#pnbuf ; dest buffer
CALL fmtreal ; Real -> ASCII
JMP wintbuf ; "write buffer
xwrbool POP BX ; write boolean
POP CX ; get boolean
PUSH BX ; restore ret
MOV DI,#sttrue ; (true)
OR CX,CX ; test boolean
JNZ wbotrue ; :true
MOV DI,#stfalse ; (false)
wbotrue PUSH CS ; str segment
CALL strload ; load string
CALL xwrtstr ; write string
RET ; "
sttrue B $04,"TRUE"
stfalse B $05,"FALSE" ; "
xwrtstr CALL limstind ; Write string: format parm
MOV BX,SP ; pos of string
INC BX ; skip ret addr
INC BX
SS:
SUB.B AL,[BX] ; field len - string len
JBE wstdoit ; :too much - no padding
MOV.B CL,AL ; -> count
XOR.B CH,CH
PUSH BX ; save string pos
wstpad MOV AL,#$20 ; put spaces
PUSH CX ; save count
CALL putbyte ; put it
POP CX ; restore count
LOOP wstpad ; :another space
POP BX ; restore string pos
wstdoit SS:
MOV.B CL,[BX] ; get length
XOR.B CH,CH ; -> count
INC BX ; point to first char
OR CX,CX ; nothing to write ?
JZ wstnil ; :yes
wstloop SS:
MOV.B AL,[BX] ; get char
PUSH BX ; save ptr, cnt
PUSH CX
CALL putbyte ; put char
POP CX ; restore
POP BX
INC BX ; next char
LOOP wstloop ; :another
wstnil POP DX ; ret addr
MOV SP,BX ; remove string from stack
JMP DX ; "return
xwrtinl POP BX ; Write inline string
CS:
MOV.B CL,[BX] ; get length
XOR.B CH,CH ; -> count
INC BX ; point to first char
JCXZ wstinil ; :null string
wstiloopCS:
MOV.B AL,[BX] ; get char
PUSH BX ; save
PUSH CX
CALL putbyte ; put char
POP CX
POP BX ; restore
INC BX ; next char
LOOP wstiloop ; :another
wstinil JMP BX ; "return - text skipped
xwrln MOV AL,#$0D ; WriteLn
CALL putbyte ; put CR
MOV AL,#$0A
JMP putbyte ; "put LF
xseekeolMOV DX,#$010D ; SeekEOLN
JMP.b seox1 ; '
xeoln MOV DX,#$000D ; EOLN
JMP.b seox1 ; '
xseekeofMOV DX,#$011A ; SEEKEOF
JMP.b seox1 ; '
xeoftx MOV DX,#$001A ; EOF
seox1 POP errpos ; get return addr
POP ES ; file var seg
PUSH errpos ; restore ret
ES:
TEST.B [DI]$02,#$80 ; open for input ?
JZ sefalse ; no: false
seloop PUSH DX ; save flag
CALL getbyte2 ; get char from file
POP DX ; restore flag
CMP.B AL,DL ; = char searched ?
JZ setrue ; yes: true
CMP AL,#$1A ; EOF ?
JZ setrue ; yes: true
CMP AL,#$20 ; space / control ?
JA sefalse ; no: false
OR.B DH,DH ; seek it ?
JZ sefalse ; :no, false
ES:
AND.B [DI]$02,#$DF ; clear flag: char pre-read
JMP seloop ; 'search it
setrue XOR AX,AX ; return true
INC AX ; setting flags
RET ; '
sefalse XOR AX,AX ; return false
RET ; "
xassign XOR.B AL,AL ; Assign: set function code
JMP doassign ; "do assign
xresettyXOR.B AL,AL ; Reset typed
JMP.b openty1 ; '
xrewrttyMOV AL,#$01 ; Rewrite typed
openty1 MOV filfunc,AL ; store function code
POP errpos ; get return addr
POP ES ; file var ptr
PUSH errpos ; restore ret
PUSH CX ; save record length
CALL closty1 ; clear record len, close file
POP CX ; remove for error exit
CMP.B errnum,#$00 ; error ?
JNZ openty2 ; :yes
PUSH CX
CALL openfile ; open that file
POP CX ; record len
CMP.B errnum,#$00 ; error ?
JNZ openty2 ; :yes
ES:
MOV [DI]$02,CX ; store record length
openty2 RET ; "
xtruncatPOP errpos ; Truncate typed, untyped
POP ES ; file var ptr
PUSH errpos ; restore ret
MOV AH,#$40 ; write
ES:
MOV BX,[DI] ; file handle
XOR CX,CX ; length = 0 -> truncate
JMP dos ; "do it
xflushtyRET $0002 ; "Flush typed, untyped
xclosetyPOP errpos ; Close typed, untyped
POP ES ; file var ptr
PUSH errpos ; restore ret
closty1 ES:
MOV [DI]$02,#$0000 ; record len = 0
JMP close2 ; "close it
xfilsel POP errpos ; Select file
POP ES ; file var ptr
MOV currfil,DI ; -> current file
MOV currfil1,ES
ES:
CMP [DI]$02,#$00 ; record len = 0 ?
JNZ selret ; no: ok
MOV.B errnum,#$04 ; File not open
selret JMP [errpos] ; "ret
xrdvar MOV filfunc,#$993F ; Read from typed file
JMP.b filrw ; 'read, unexpected EOF
xwrvar MOV filfunc,#$F040 ; Write to typed file
filrw POP BX ; write, disk write error
POP SI ; var seg
PUSH BX ; restore ret
CMP.B errnum,#$00 ; error ?
JNZ filrwret ; yes: no operation
MOV DX,DI ; save DI
LES DI,currfil ; current file var
MOV.B AH,filfunc ; save function, error code
ES:
MOV BX,[DI] ; file handle
ES:
MOV CX,[DI]$02 ; record length
PUSH DS ; save DS
MOV DS,SI ; ptr var
CALL dos ; do it
POP DS ; restore DS
JB filrwerr ; :error
CMP AX,CX ; length = expected ?
JZ filrwret ; :yes
CMP.B filfunc,#$3F ; read ?
JNZ filrwerr ; no: error
OR AX,AX ; test count
JZ filrwerr ; nothing done: error
ES:
MOV CX,[DI]$02 ; record length
MOV DI,DX ; restore dest ofs
ADD DI,AX ; add count read
MOV ES,SI ; dest seg
SUB CX,AX ; count to fill
XOR AX,AX ; pad with zeroes
CLD
REPZ ; do fill
STOS.B
RET ; '
filrwerrMOV AL,filerr ; error code -> error
MOV errnum,AL
filrwretRET ; "
xseek XOR DX,DX ; Seek: clear high word
seek1 POP errpos ; set error pos
POP DI ; get file var ptr
POP ES
PUSH errpos ; restore ret
ES:
MOV CX,[DI]$02 ; get record length
CALL cardmul ; * pos -> DX:AX
MOV CX,DX ; -> CX:DX
MOV DX,AX
MOV AX,#$4200 ; seek absolute
ES:
MOV BX,[DI] ; file handle
PUSH CX ; save pos wanted
PUSH DX
CALL dos ; do it
POP CX ; restore pos wanted
POP BX
JB seekerr ; :error
CMP AX,CX ; pos = expected ?
JNZ seekerr ; :no
CMP DX,BX
JZ seekret ; :yes
seekerr MOV.B errnum,#$91 ; Seek beyond EOF
seekret RET ; "
xlngseekCALL realcard ; LongSeek: convert real
JMP seek1 ; "do it
xeofty POP BX ; EOF typed, untyped
POP ES ; get file var ptr
PUSH BX ; restore ret
MOV AX,#$4406 ; get unit status
ES:
MOV BX,[DI] ; file handle
CALL dos ; do it
OR.B AL,AL ; test result
MOV AX,#$0000 ; false
JNZ eoffalse ; :ok
INC AX ; true
eoffalseOR AX,AX ; set flags
RET ; "
xfileposPOP BX ; FilePos: ret addr
POP ES ; file var ptr
PUSH BX ; restore ret
filpos1 MOV AX,#$4201 ; seek relative
ES:
MOV BX,[DI] ; file handle
XOR CX,CX ; no offset
XOR DX,DX
CALL dos ; get position
filpos2 ES:
MOV CX,[DI]$02 ; record length
JMP.b carddiv ; "pos / reclen -> filepos
NOP ; LongFilePos
xlfilposPOP BX ; return addr
POP ES ; file var ptr
PUSH BX ; restore ret
CALL filpos1 ; do it
JMP cardreal ; "result -> real
xfilesizPOP BX ; FileSize: ret addr
POP ES ; file var ptr
PUSH BX ; restore ret
filsiz1 MOV AX,#$4201 ; seek relative
ES:
MOV BX,[DI] ; file handle
XOR CX,CX ; no offset
XOR DX,DX
CALL dos ; get current pos
PUSH AX ; save it
PUSH DX
MOV AX,#$4202 ; seek from end
ES:
MOV BX,[DI] ; file handle
XOR CX,CX ; no offset
XOR DX,DX
CALL dos ; get end position
POP CX ; restore current pos
POP BX
PUSH AX ; save end pos
PUSH DX
MOV DX,BX ; restore file pos
MOV AX,#$4200 ; seek absolute
ES:
MOV BX,[DI] ; file handle
CALL dos ; go back to old pos
POP DX ; end position
POP AX
ES:
MOV CX,[DI]$02 ; (pos+reclen-1)
DEC CX
ADD AX,CX
ADC DX,#$00
JMP filpos2 ; "/ reclen -> position
xlfilsizPOP BX ; LongFileSize: ret addr
POP ES ; file var ptr
PUSH BX ; restore ret
CALL filsiz1 ; do it
JMP cardreal ; "result -> real
carddiv CMP CX,#$01 ; long cardinal division
JZ cdret ; / 1: done
MOV SI,CX ; DX:AX / CX -> DX:AX
XOR BX,BX ; clear result
MOV CX,#$0021 ; 32 bits
cdloop RCL BX,1 ; shift in result
SBB BX,SI ; try subtraction
JNB cdbit1 ; :ok
ADD BX,SI ; restore it
STC
cdbit1 CMC ; make flag to shift in
RCL AX,1 ; shift in result
RCL DX,1
LOOP cdloop ; :another bit
cdret RET ; "
cardmul MOV BX,AX ; long card mul
MOV AX,DX ; DX:AX * CX -> DX:AX
MUL CX ; higher word
XCHG AX,BX ; save it
MUL CX ; lower word
ADD DX,BX ; add higher result
RET ; "
xresetunXCHG AX,CX ; Reset untyped: record length
POP BX ; ret addr
POP DI ; file var ofs
PUSH BX ; restore ret
JMP xresetty ; "now like typed file
xrewrtunXCHG AX,CX ; Rewrite untyped: record length
POP BX ; ret addr
POP DI ; file var ofs
PUSH BX ; restore ret
JMP xrewrtty ; "now like typed file
xblkrd MOV filfunc,#$993F ; BlockRead
JMP.b blrw1 ; 'read, unexpected EOF
xblkwr MOV filfunc,#$F040 ; BlockWrite
blrw1 POP errpos ; write, disk write error
POP DX ; var seg
POP SI ; var ofs
POP DI ; file var ptr
POP ES
PUSH AX ; save length
CALL blrw ; do it
POP CX ; restore len
CMP.B errnum,#$00 ; error ?
JNZ blrw1ok ; yes: return
CMP AX,CX ; length = expected
JZ blrw1ok ; :yes
MOV AL,filerr ; error code -> error
MOV errnum,AL
blrw1ok JMP [errpos] ; "return
xblkrdrdMOV filfunc,#$993F ; BlockRead with result var
JMP.b blrwres ; '
xblkwrrsMOV filfunc,#$F040 ; BlockWrite with result var
blrwres POP errpos ; get error pos
MOV CX,DI ; result var ptr
POP BX
POP AX ; length
POP DX ; var seg
POP SI ; var ofs
POP DI ; file var ptr
POP ES
PUSH BX ; save result var ptr
PUSH CX
CALL blrw ; do it
POP DI ; restore result var ptr
POP ES
ES:
MOV [DI],AX ; store record count
JMP [errpos] ; "return
blrw ES: ; do Block-R/W
CMP [DI]$02,#$00 ; record length = 0 ?
JZ blrwerr ; yes: file not open
ES:
CMP [DI]$02,#$01 ; record len = 1 ?
JZ blrwbyt ; :no calculation
PUSH DX ; save
ES:
MUL [DI]$02 ; count * record length
POP DX ; restore
blrwbyt XCHG AX,CX ; length -> CX
MOV.B AH,filfunc ; function code
ES:
MOV BX,[DI] ; file handle
PUSH DS ; save DS
MOV DS,SI ; var seg
CALL dos ; do file operation
POP DS ; restore DS
JNB blrwok ; :ok
MOV AL,filerr ; error code -> error
MOV errnum,AL
XOR AX,AX ; nothing read / written
blrwok ES:
MOV CX,[DI]$02 ; record length
CMP CX,#$01 ; = 1 ?
JZ blrwret ; yes: no division
MOV DI,DX ; offset + count done
ADD DI,AX
XOR DX,DX ; clear hi
DIV CX ; count done / record len
OR DX,DX ; test remainder
JZ blrwret ; :ok
CMP.B filfunc,#$3F ; read ?
JNZ blrwret ; no: end it
PUSH AX ; save count done
SUB CX,DX ; fill up the rest
MOV ES,SI ; var seg
XOR AX,AX ; with zeroes
CLD
REPZ ; do it
STOS.B
POP AX ; restore result
INC AX ; +1
blrwret RET ; '
blrwerr MOV.B errnum,#$04 ; File not open
RET ; "
xerase POP errpos ; Erase
POP ES ; file var ptr
PUSH errpos ; restore ret
MOV AH,#$41 ; delete file
LEA DX,[DI]$0C ; ptr to filename
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
CALL dos ; do it
POP DS ; restore DS
JNB eraret ; :no error
eraerr MOV.B errnum,#$01 ; file not found
eraret RET ; "
xrename POP errpos ; Rename
CALL getpn ; convert string -> ASCIIZ
POP DI ; file var ptr
POP ES
PUSH errpos ; restore ret
MOV AH,#$56 ; Rename file
LEA DX,[DI]$0C ; current file name
PUSH DI ; save addr
MOV DI,#pnbuf ; filename ptr
PUSH DS ; ES <-> DS
PUSH ES
POP DS
POP ES
CALL dos ; do rename
PUSH DS ; ES <-> DS
PUSH ES
POP DS
POP ES
POP DI ; restore addr
JB eraerr ; :error
MOV SI,#pnbuf ; copy new name into file var
LEA DI,[DI]$0C ; file var offset
MOV CX,#$0020 ; 64 bytes
CLD
REPZ
MOVS ; copy it
RET ; "
xchdir POP errpos ; ChDir: get error pos
CALL getpn ; get path name
PUSH errpos ; restore ret
MOV AX,pnbuf ; get drive #
OR.B AL,AL ; end of name ?
JZ chdirret ; yes: return
CMP.B AH,#$3A ; : ?
JNZ chdir1 ; no: no drive specified
CALL upcase ; upcase drive number
SUB AL,#$41 ; - A
JB eraerr ; <:error
CMP AL,#$0F ; max. O
JNB eraerr ; :error.
; Please note that MS-DOS now allows more drives !!!
MOV AH,#$0E ; set default drive
MOV.B DL,AL ; drive number
CALL dos ; set it
CMP.B pnbuf2,#$00 ; pathname ?
JZ chdirret ; :none given
chdir1 MOV AH,#$3B ; change dir
chdir2 MOV DX,#pnbuf ; pointer to pathname
CALL dos ; set it
JB eraerr ; :error
chdirretRET ; "
xmkdir MOV BH,#$39 ; MkDir
JMP.b rmdir1 ; '
xrmdir MOV BH,#$3A ; RmDir
rmdir1 POP errpos ; return addr -> error pos
CALL getpn ; get path name
PUSH errpos ; restore ret
MOV.B AH,BH ; get function code
JMP chdir2 ; "do it
xgetdir POP errpos ; GetDir: CL=max. string len
POP ES ; dest string
POP AX ; drive number
PUSH errpos ; restore ret
OR.B AL,AL ; default drive ?
JNZ gdnotdef ; :no
MOV AH,#$19 ; get default drive number
CALL dos
INC.B AL ; +1
gdnotdefMOV.B DL,AL ; drive number
ADD AL,#$40 ; -> drive name
MOV pnbuf,AL ; store in buffer
MOV pnbuf1,#$5C3A ; store :\
MOV AH,#$47 ; read current access path
MOV SI,#pnbuf3 ; dest ptr
CALL dos ; do it
JNB gddone ; :ok
MOV.B [SI],#$00 ; no path - mark end
gddone MOV SI,#pnbuf ; pointer to path name
XOR BX,BX ; clear len counter
gdloop MOV.B AL,[SI] ; get char
OR.B AL,AL ; end ?
JZ gdend ; :yes
INC SI ; next char
INC BX ; count length
ES:
MOV.B [BX_DI],AL ; store in dest string
DEC.B CL ; space available ?
JNZ gdloop ; :yes
gdend ES: ; store length
MOV.B [DI],BL
RET ; "
xexecuteMOV BX,#$2C7C ; Execute
JMP.b chain1
xchain XOR BX,BX ; Chain: load all of it
chain1 POP errpos ; get ret addr
POP ES ; file var ptr
PUSH errpos ; restore ret
TEST modeflg,#$0001 ; direct mode ?
JNZ cherr2 ; yes: error
PUSH BX ; save begin offset
MOV AX,#$3D00 ; open file
LEA DX,[DI]$0C ; ptr to filename
CALL dos ; do it
POP DX ; begin offset
JB cherr1 ; :error
MOV BX,AX
MOV AX,#$4200 ; seek absolute
XOR CX,CX ; clr hi word
CALL dos ; do seek
JB cherr1 ; :error
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
MOV AH,#$3F ; read byte block
MOV CX,#$FFFF ; as much as possible
MOV DX,#start ; destination
CALL dos ; do it
POP DS ; restore DS
MOV AH,#$3E ; close file
CALL dos
MOV SP,spval ; restore SP
CALL reinit2 ; reinit files, I/O
MOV verror,#$10D0 ; set break vector
JMP start2 ; 'start - no memory init
cherr1 MOV DL,#$01 ; File not found
JMP operr ; '
cherr2 MOV.B errnum,#$21 ; Not allowed in direct mode
RET ; "
start JMP.b kstart ; 'skip message
B "Licensed Material. Program Property of B"
B "ORLAND." ; '
kstart CALL readvers ; read version number
MOV AX,#$9C06 ; (program size+15)/16
MOV CL,#$04
SHR AX,CL
MOV DX,CS ; +CS -> DS
ADD DX,AX
MOV DS,DX
CS:
MOV AX,availmem ; top of memory
SUB AX,DX
MOV freemem,AX ; max memory size
MOV BX,#$FFFE ; stack pointer
SUB AX,#$1000 ; mem - 64K
JNB kmembig ; :ok
MOV BX,freemem ; max memory size
MOV CL,#$04 ; small memory: SS at end of DS
SHL BX,CL ; calc SP
XOR AX,AX ; no segment offset
kmembig ADD AX,DX ; add to DS
MOV stackseg,AX ; -> stack segment
MOV stackpt,BX ; -> stack pointer
MOV AX,freemem ; max memory size
SUB AX,#$0040 ; - 64 paragraphs
CMP AX,#$1000 ; = 64K ?
JB kmemlim ; :less
MOV AX,#$1000 ; limit to 64K
kmemlim MOV CL,#$04
SHL AX,CL
DEC AX
MOV txmemend,AX ; store -> end of text space
XOR AX,AX
kmeminitMOV SS,stackseg ; set stack segment
MOV SP,stackpt ; set stack pointer
PUSH AX ; save flag
MOV CX,#$0010 ; 16 files
CALL initio ; init files, I/O
POP AX ; get flag
OR AX,AX ; test it
PUSH AX ; save it again
JNZ kcrtinit ; :set
CALL xcrtinit ; CrtInit
kcrtinitCALL klowvid ; LowVideo
CALL knrmvid ; NormVideo
POP AX ; get flag
OR AX,AX ; test it
JZ kinitvar ; :init
JMP kmainlp ; 'go to main loop
kinitvarMOV AX,#txstrt ; init vars
MOV txbeg,AX ; beg of text
MOV txend,AX ; end of text
XOR AX,AX ; clear vars
MOV mincssz,AX ; min CS-size = 0
MOV mindssz,AX ; min DS-size = 0
MOV minhpsz,#$0400 ; min free heap = 16K
MOV maxhpsz,#$A000 ; max free heap = 640K
MOV workpn,AL ; clear work filename
MOV mainpn,AL ; clear main filename
MOV parmlin,AL ; clear param line
MOV errio,AL ; clear error
MOV.B codedest,#$01 ; code destination: memory
CALL inited ; init variables
MOV AH,#$19 ; get default drive
CALL dos
MOV defdrv,AL ; store it
CALL xclrscr ; ClrScr
CALL prints ; write string
B "---------------------------------------",$0D
B $0A,"TURBO Pascal system ",$00
CALL klowvid ; do LowVideo
CALL prints ; write string
B "Version 3.01A",$00
CALL knrmvid ; do HighVideo
CALL prints ; write string
B $0D,$0A," ",$00
CALL klowvid
CALL prints
B "PC-DOS",$00
CALL knrmvid
CALL prints
B $0D,$0A,$0A,$00
CALL klowvid
CALL prints
B "Copyright (C) 1983,84,85",$00
CALL knrmvid
CALL prints
B " BORLAND Inc.",$0D,$0A,"-----------------------"
B "----------------",$0D,$0A,$0A,$00
MOV BX,#displstr ; write display type
CALL putstr
CALL prints
B $0D,$0A,$0A,$0A,$0A,"Include error messages",$00
CALL yornln ; Y or N ?
MOV msgflg,AL ; store flag
JZ kclr ; :no
CALL kreaderr ; read error messages
kclr CALL kclrtxt ; clear text
CALL kmenu ; write menu
kmainlp MOV SP,stackpt ; main loop: restore SP
MOV BX,#kmainlp ; set a return addr
PUSH BX
CMP.B errio,#$00 ; error ?
JZ kgetcmd ; :no
JMP kdofind ; 'search error
kgetcmd CALL printatt ; write string with attributes
B $8D,$8A,$BE,$00 ; CR,LF,>
CALL knrmvid
CALL keyget ; get command
CALL upcase ; convert to upper case
PUSH AX ; save it
CALL xwriteln ; WriteLn
POP AX ; restore command
MOV SI,#kcmdtab ; ptr to command table
CALL srchcmd ; search command
JB kmenu ; not found: write menu
CS:
JMP [SI]$01 ; "execute command
kreaddefCLD ; Transfer string into CON buffer
MOV DI,#coninbuf ; dest ptr
PUSH DS ; DS -> ES
POP ES
kreaddl LODS.B ; SI: source ptr
STOS.B ; copy string
OR.B AL,AL ; test for end
JNZ kreaddl ; :no
kreadln CALL prints ; Readln: write string
B ": ",$00
CALL rdedit ; read with editing
MOV BX,#coninbuf ; buffer ptr
CALL xwriteln ; WriteLn
krdln1 MOV.B AL,[BX] ; get char from buffer
CMP AL,#$1A ; ^Z ?
JZ krdlnret ; yes - end
CMP AL,#$20 ; space ?
JNZ krdlnret ; :no, ret
INC BX ; skip spaces
JMP krdln1 ; 'continue scanning
krdlnretRET ; "BX now points into buffer
krdend CMP.B [BX],#$1A ; Test end of line
RET ; "
kmenu CALL knrmvid ; Write menu
CALL xclrscr ; ClrScr
CALL printatt
B $CC,"ogged drive: ",$80,$00
MOV AH,#$19 ; get default drive
CALL dos
ADD AL,#$41 ; convert to ASCII
CALL conput ; write its name
CALL printatt
B $0D,$0A,$C1,"ctive directory: ",$DC,$00
MOV AH,#$47 ; get active directory
XOR.B DL,DL ; default drive
MOV SI,#pnbuf ; dest buffer
CALL dos ; do it: get pathname
CALL printpn ; write that pathname
CALL printatt
B $0D,$0A,$0A,$D7,"ork file: ",$80,$00
CALL kwworkpn ; write current filename
CALL printatt
B $0D,$0A,$CD,"ain file: ",$80,$00
MOV SI,#mainpn ; main filename
CALL printpn ; write it
CALL printatt ; write command menu
B $0D,$0A,$0A,$C5,"dit ",$C3,"ompile ",$D2,"un ",$D3
B "ave",$0D,$0A,$0A,$C4,"ir ",$D1,"uit compiler ",$CF
B "ptions",$0D,$0A,$0A,"Text: ",$00
MOV AX,txend ; end of text
SUB AX,txbeg ; - beg of text
CALL kbytes ; print number
CALL prints
B "Free: ",$00
MOV AX,txmemend ; top of text space
SUB AX,txend ; - end of text
kbytes CALL knumax ; print number
CALL prints
B " bytes",$0D,$0A,$00
RET ; "
kcdest DEC.B AL ; show code direction: this one ?
JNZ kcdestno ; count it down: no
CALL printatt
B "compile -> ",$00
RET ; '
kcdestnoCALL printatt ; clear field
B " ",$00
RET ; "
optmenu MOV AX,#optmenu ; Option-menu
PUSH AX ; put return addr
optmenu2CALL xclrscr ; ClrScr
MOV AL,codedest ; code destination
CALL kcdest ; show it
CALL printatt
B $CD,"emory",$0D,$0A,$00
CALL kcdest ; show it
CALL printatt
B $C3,"om-file",$0D,$0A,$00
CALL kcdest ; show it
CALL printatt
B "c",$C8,"n-file",$0D,$0A,$0A,$0A,$00
CMP.B codedest,#$02 ; to COM-file ?
JZ optmcom ; :yes
JMP optmparm ; '
optmcom CALL printatt ; display memory information
B "minimum c",$CF,"de segment size: ",$00
CALL knrmvid
MOV AX,mincssz ; min CS size
CALL whexword ; write hex
CALL printatt
B " (max ",$00
MOV AX,#$2D8B ; -(runtime size+15)/16
MOV CL,#$04
SHR AX,CL
NEG AX
ADD AX,#$1000 ; + 64K
CALL kpara ; write paragraphs
CALL printatt
B ")",$0D,$0A,"minimum ",$C4,"ata segment size: ",$00
CALL knrmvid
MOV AX,mindssz ; min DS size
CALL whexword ; write hex
CALL printatt
B " (max ",$00
MOV AX,#$024F ; -(min vars used+15)/16
MOV CL,#$04
SHR AX,CL
NEG AX
ADD AX,#$1000 ; + 64K
CALL kpara ; write paragraphs
CALL printatt
B ")",$0D,$0A,"m",$C9,"nimum free dynamic memory: ",$00
CALL knrmvid
MOV AX,minhpsz ; min free heap
CALL whexword ; write hex
CALL klowvid
CALL kparastr ; write paragraphs
CALL printatt
B $0D,$0A,"m",$C1,"ximum free dynamic memory: ",$00
CALL knrmvid
MOV AX,maxhpsz ; max free heap
CALL whexword ; write hex
CALL klowvid
CALL kparastr ; write paragraphs
JMP.b optmget
optmparmCALL printatt
B "command line ",$D0,"arameters: ",$00
CALL knrmvid
MOV SI,#parmlin ; display command line
CALL kwstrsi
optmget CALL printatt
B $0D,$0A,$0A,$0A,$C6,"ind run-time error ",$D1,"uit",$0D
B $0A,$0A,$BE,$00
CALL knrmvid
CALL keyget ; get command
CALL upcase ; convert to upper case
PUSH AX ; save it
CALL xwriteln ; WriteLn
POP AX ; restore cmd
MOV SI,#ocmdtab ; ptr to command table
CALL srchcmd ; search command
JNB optexe ; :ok
JMP optmenu2 ; 'not found - repeat
optexe CS:
JMP [SI]$01 ; "execute command
yornln CALL yorn ; Y or N ?
PUSHF ; save result
PUSH AX
CALL xwriteln ; WriteLn
POP AX ; restore result
POPF
RET ; "
yorn CALL prints ; Y or N ?
B " (Y/N)? ",$00
yornlp CALL keyget ; get char
CALL upcase ; convert to upper
CMP AL,#$59 ; Y ?
JZ yornok ; :yes
CMP AL,#$4E ; N ?
JNZ yornlp ; no: loop back
yornok PUSH AX ; save key
CALL conput ; display choice
POP AX ; restore it
SUB AL,#$4E ; set flags:
RET ; "0=no
waitesc CALL prints ; Wait for ESC
B ". Press <ESC>",$00
waitesclCALL keyget ; get char
CMP AL,#$1B ; ESC ?
JNZ waitescl ; :no, wait
RET ; "
srchcmd CS: ; Search command in table
CMP.B AL,[SI] ; compare it
JZ srcmdfnd ; :found
ADD SI,#$03 ; go to next entry
CS:
CMP.B [SI],#$00 ; end of table ?
JNZ srchcmd ; :no
STC ; not found !
srcmdfndRET ; "
kcmdtab B "L" ; main command table
W klogged
B "A"
W kactdir
B "W"
W kwork
B "M"
W kmain
B "E"
W editor
B "C"
W kcomp
B "R"
W krun
B "S"
W ksave
B "D"
W kdir
B "O"
W optmenu
B "Q"
W kquit
B $00 ; "end of table
B "M" ; option command table
W kmem
B "C"
W kcom
B "H"
W kchn
B "O"
W kcs
B "D"
W kds
B "I"
W kss
B "A"
W kmss
B "P"
W kparm
B "F"
W kfind
B "Q"
W optquit
B $00 ; "end of table
optquit POP AX ; Quit submenu
JMP kmenu ; "jump to main menu
; pathname of message file (installed by TINST)
errpath B "TURBO.MSG",$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00, ; "
extpas B $04,".PAS" ; table of file extensions
extcom B $04,".COM"
extbak B $04,".BAK"
extchn B $04,".CHN" ; "
fnpath B $04,"\*.*" ; search parameters
fnany B $03,"*.*" ; "
kmain CALL prints ; M:Main file name
B $0D,$0A,"Main file name",$00
CALL knocode ; flag: text not compiled
MOV SI,#mainpn ; pointer to pathname
CALL kreaddef ; Enter new name
MOV.B mainpn,#$00 ; mark end
JZ kmret ; :nothing read
CALL kpasext ; parse filename
MOV DI,#mainpn ; dest buffer
CALL fnscdi ; copy to main file name
kmret RET ; "
; W:Work file name
kwork MOV vnewfil,#flnew ; set error vec: new file
CALL ksvchng ; save, if changed
CALL prints
B $0D,$0A,"Work file name",$00
MOV SI,#workpn ; ptr work file name
CALL kreaddef ; Enter new name
MOV.B workpn,#$00 ; mark end
JNZ kwok ; :something read
CALL kclrtxt ; clear text
JMP kmainlp ; 'back to main menu
kwok CALL kpasext ; parse filename
MOV DI,#workpn ; copy to work file name
CALL fnscdi
JMP.b kw2 ; 'now load it
kwload MOV vnewfil,#flescclr ; set error vec: not found
kw2 MOV vfilbig,#flbigclr ; set error vec: too big
CALL kclrtxt ; clear text
MOV SI,#workpn ; work file name
kwload2 MOV BX,txbeg ; beg of text
PUSH BX ; save parms
PUSH SI
CALL clred ; clear editor vars
POP SI
POP BX ; restore
MOV DX,BX ; begin addr
MOV CX,txmemend ; end of space
CALL kload ; load file
INC BX
MOV txend,BX ; set end of text
RET ; "
kload PUSH DX ; Load file: save start pos
PUSH CX ; save end pos
CALL fnsisc ; copy pathname[SI]
CALL prints
B $0D,$0A,"Loading ",$00
CALL kwscrpn ; write pathname
MOV AX,#$3D00 ; open file
MOV DX,#scrpn ; current pathname
PUSH DS ; DS -> ES
POP ES
CALL dos ; do it
MOV BX,AX ; file handle
POP CX ; restore parms
POP DX
JB flntfnd ; :error
kload2 SUB CX,DX ; calc max length
MOV AH,#$3F ; read byte block
CALL dos ; do it
JB flntfnd ; :error
CMP AX,CX ; length = expected ?
JZ fltoobig ; yes: too big !
XCHG AX,CX ; get length done
MOV DI,DX ; end addr
PUSH DS ; DS -> ES
POP ES
MOV AL,#$1A ; search ^Z in the block
CLD
REPNZ
SCAS.B
JNZ klnoeof ; :not found
DEC DI ; go back one byte
klnoeof MOV AH,#$3E ; close file
CALL dos
DEC DI
MOV BX,DI ; end pos of text read
RET ; "
fltoobigCALL klnoeof ; file too large: close file
MOV BX,DX ; end of text space
INC BX ; +1
JMP [vfilbig] ; "handle error
flntfnd MOV BX,DX ; file not found
DEC BX ; end addr
JMP [vnewfil] ; "handle error
flesc CALL xwriteln ; File not found - ESC
CALL vidattr3 ; attribute #3
CALL prints
B "File not found",$00
flesc2 CALL waitesc ; wait for ESC
JMP knrmvid ; "HighVideo
flescclrCALL flesc ; file not found - ESC
JMP.b flclr ; "clear work file name
flnew CMP AL,#$03 ; New file: test error code
JZ fldir ; :invalid dir
CALL xwriteln ; WriteLn
CALL vidattr2 ; attribute #2
CALL prints
B "New File",$00
CALL knrmvid
PUSH BX ; save end pos
MOV BX,#$07D0 ; wait 2 s
CALL delaybx
POP BX ; restore
RET ; '
fldir CALL xwriteln ; WriteLn
CALL vidattr3 ; Attribute #3
CALL prints
B "Invalid directory",$00
JMP.b flclr ; "clear work file name
flbig CALL xwriteln ; File too big
CALL vidattr3
CALL prints
B "File too big",$00
MOV BX,txend ; end of text-1 -> BX
DEC BX
JMP flesc2 ; "wait for ESC
flbigclrCALL flbig ; file too big
flclr MOV.B workpn,#$00 ; clear work file name
JMP kmainlp ; "main loop
ksvchng XOR AX,AX ; Save if modified
INC AX ; set flag
JMP.b ksv2 ; '
ksvnoaskXOR AX,AX
ksv2 CMP.B txchg,#$00 ; text changed ?
JZ ksvret ; :no - ret
OR AX,AX ; test flag
JZ ksave
CALL prints
B "Workfile ",$00
CALL kwworkpn ; write path name
CALL prints
B " not saved. Save",$00
MOV.B txchg,#$00 ; clear change flag
CALL yornln ; Y or N ?
JNZ ksave ; :yes
ksvret RET ; '
ksave CALL kgetfn ; S:Save file - get filename
MOV.B txchg,#$00 ; clear change flag
MOV SI,#workpn ; ptr work file name
CALL fnsisc ; copy it
CALL prints
B $0D,$0A,"Saving ",$00
CALL kwworkpn ; write path name
MOV DI,#pnbuf
CALL fnscdi ; copy filename into buffer
MOV SI,#extbak ; extension .BAK
CALL kext ; modify file name
MOV AH,#$41 ; delete old .BAK file
MOV DX,#scrpn ; scratch file name
CALL dos ; do it
MOV AH,#$56 ; rename file
MOV DX,#pnbuf ; current filename
MOV DI,#scrpn ; new filename
CALL dos ; do it: rename to .BAK
MOV AH,#$3C ; create new file
XOR CX,CX ; no attribute
MOV DX,#pnbuf ; current filename
PUSH DS ; DS -> ES
POP ES
CALL dos ; do create
JB ksren ; :error
XCHG AX,BX ; file handle
MOV DX,txbeg ; beg -> offset
MOV CX,txend ; end of text
MOV DI,CX
MOV.B [DI],#$1A ; store ^Z at the end
SUB CX,DX ; calc length
INC CX ; +1
MOV AH,#$40 ; write byte block
CALL dos ; do it
JB kserr ; :error
CMP AX,CX ; length = expected ?
JNZ kserr ; :no
JMP klnoeof ; 'close that file
kserr MOV.B txchg,#$FF ; set changed flag
CALL klnoeof ; close that file
MOV AH,#$41 ; erase new file
MOV DX,#pnbuf
CALL dos
ksren MOV AH,#$56 ; rename it back to .PAS
MOV DX,#scrpn ; .BAK
MOV DI,#pnbuf ; -> .PAS
CALL dos ; do it
CALL xwriteln ; WriteLn
CALL ksfull ; write message
JMP kmainlp ; "return to main menu
ksfull CALL vidattr3 ; File not saved
CALL prints
B "Disk full or invalid directory path",$00
CALL waitesc ; wait for ESC
JMP knrmvid ; "
kdir CALL prints ; D:Directory
B "Dir mask",$00
CALL kreadln ; enter dir mask
MOV CX,#$000D ; *, ? allowed
CALL kparse2 ; parse filename
CALL krdend ; line end ?
MOV AH,#$1A ; set DMA transfer addr
MOV DX,#pnbuf ; buffer
CALL dos
MOV SI,#scrpn ; test pathname
kdtest MOV.B AL,[SI] ; get char
INC SI ; go to next
CMP AL,#$2A ; * ?
JZ kddoit ; :yes
CMP AL,#$3F ; ?
JZ kddoit ; :yes
OR.B AL,AL ; end of string ?
JNZ kdtest ; :no
MOV.B AL,[SI]-$02 ; get last char
MOV SI,#fnany ; ptr to *.*
CMP AL,#$3A ; : ?
JZ kdwrit ; :yes
CMP AL,#$5C ; \ ?
JZ kdwrit ; :yes
MOV AH,#$4E ; search first dir entry
MOV CX,#$0010 ; attribute
MOV DX,#scrpn ; pathname
CALL dos ; do it
JB kddoit ; :error
TEST.B pndiratt,#$10 ; attribute ok ?
JZ kddoit ; yes, take it
MOV SI,#fnpath ; ptr to \*.*
kdwrit CALL kext2
kddoit CALL prints
B "Directory of ",$00
CALL kwscrpn ; write path name
CALL xwriteln ; WriteLn
MOV AH,#$4E ; get first entry
MOV CX,#$0010 ; attribute
MOV DX,#scrpn ; path name
CALL dos ; do it
JB kderr ; :error
XOR.B DL,DL ; clear flag
kddis OR.B DL,DL ; test flag
JNZ kdnocr ; :not first entry in line
CS:
MOV AL,txwinx2 ; line length / 16
XOR.B AH,AH
MOV DL,#$10
DIV.B DL
MOV.B DL,AL
kdnocr MOV SI,#pndirnm ; ptr to filename
TEST.B [SI]-$09,#$10 ; test attribute
JZ kdnodir ; :ok
CMP.B [SI],#$2E ; directory ?
JZ kdnext
CALL klowvid ; LowVideo
kdnodir CALL printpn ; write name
CALL knrmvid ; NormVideo
DEC.B DL ; another one in this line ?
JZ kdnextln ; :no
MOV CX,#pndirpad ; end for padding
SUB CX,SI ; calc length
kdpad MOV AL,#$20 ; pad with spaces
CALL conput ; write space
LOOP kdpad ; :another one
JMP.b kdnext ; 'next dir entry
kdnextlnCALL xwriteln ; WriteLn
kdnext MOV AH,#$4F ; get next entry
PUSH DX ; save tab
CALL dos ; get it
POP DX ; restore tab
JNB kddis ; :ok, write it
OR.B DL,DL ; (redundant !)
JMP.b kdend ; 'end it
kderr CALL xwriteln ; WriteLn
CALL vidattr2
CALL prints
B "No files",$00
CALL knrmvid
MOV DL,#$01 ; do CR
kdend OR.B DL,DL ; test tab flag
JZ kdend2 ; :no CR
CALL xwriteln ; WriteLn
kdend2 CALL xwriteln ; WriteLn
MOV.B DL,scrpn ; get drive number
SUB.B DL,#$40 ; convert
MOV AH,#$36 ; get disk free space
CALL dos
CMP AX,#$FFFF ; invalid drive ?
JZ kdret ; :yes
MUL CX ; calc bytes/block
OR DX,DX ; many ?
JNZ kdret ; :yes
MUL BX ; * number free blocks
MOV CL,#$0A ; DIV 1024
SHR AX,CL
MOV CL,#$06
SHL DX,CL
ADD AX,DX
CALL knum1 ; write number
CALL prints
B "k bytes free",$00
kdret RET ; "
klogged CALL prints ; L:Logged drive
B "New drive",$00
CALL kreadln ; Read line
MOV.B AL,[BX] ; get char from buffer
CMP AL,#$1A ; EOF ?
JNZ kldef ; :no
MOV AH,#$19 ; get default drive
CALL dos
JMP.b kldef2 ; 'ok
kldef CALL upcase ; convert it
SUB AL,#$41 ; < A ?
JB klret ; :wrong
CMP AL,#$0F ; > O ?
JA klret ; :wrong
kldef2 PUSH AX ; save it
MOV AH,#$0D ; reset disk system
CALL dos
POP DX ; restore drive
MOV AH,#$0E ; set default drive
CALL dos
klret RET ; "
kactdir CALL prints ; A:Active directory
B "New directory",$00
CALL kreadln ; read string
JZ karet ; nothing: ret
MOV SI,BX ; source
MOV DX,#pnbuf ; dest: std pathname
MOV DI,DX
MOV CX,#$0040 ; 64 bytes
PUSH DS ; DS -> ES
POP ES
CLD ; copy it
REPZ
MOVS.B
MOV DI,DX ; restore ptr to beg
MOV AL,#$1A ; search ^Z
MOV CX,#$0040
REPNZ
SCAS.B
JNZ kaerr ; not found: invalid
MOV.B [DI]-$01,#$00 ; mark end with 0
MOV AH,#$3B ; change directory
CALL dos
OR.B AL,AL ; error ?
JZ karet ; :no
kaerr MOV AL,#$07 ; Bell
CALL conput ; write it
karet RET ; "
kspace CALL prints ; Display space information
B "Code: ",$00
MOV BX,#$2D8B ; (code size-runtime length)/16
MOV CL,#$04
SHR BX,CL
MOV AX,codesize ; (already in paras)
SUB AX,BX
AND AX,#$0FFF
CALL ksize ; write number
CALL prints
B ", ",$00
MOV AX,#$1000 ; (64K-code size)/16
SUB AX,codesize
AND AX,#$0FFF
CALL kpara ; write para
CALL prints
B " free",$0D,$0A,"Data: ",$00
MOV BX,#$024F ; (Data size-std vars)/16
MOV CL,#$04
SHR BX,CL
MOV AX,datasize ; (already paras)
SUB AX,BX
AND AX,#$0FFF
CALL ksize ; write number
CALL prints
B ", ",$00
MOV AX,#$1000 ; (64K-data size)/16
SUB AX,datasize
AND AX,#$0FFF
CALL kpara ; write para
CALL prints
B " free",$0D,$0A,$00
CMP.B codedest,#$01 ; code destination ?
JZ kspmem ; :memory
CMP.B codedest,#$02
JZ kspcom ; :COM-File
RET ; '
kspmem CALL prints
B "Stack/Heap: ",$00
MOV AX,minstksz ; display min stack size
CALL ksize ; write number
JMP xwriteln ; 'WriteLn
kspcom CALL prints
B "Stack/Heap: ",$00
MOV AX,minhpsz ; min heap/stack size
CALL ksize ; write number
CALL prints
B " (minimum)",$0D,$0A," ",$00
MOV AX,maxhpsz ; max heap/stack size
CALL ksize ; write number
CALL prints
B " (maximum)",$0D,$0A,$00
RET ; "
ksize PUSH AX ; write number hex and dec
CALL kpara ; write para
CALL prints
B " (",$00
POP AX ; restore number
XOR DX,DX ; clear hi
MOV CX,#$0004
ksize2 SHL AX,1 ; * 16
RCL DX,1
LOOP ksize2 ; :another shift
MOV BX,AX ; number
MOV CX,#$0006 ; field length
CALL knum ; write DX:BX
CALL prints
B " bytes)",$00
RET ; "
kpara CALL whexword ; Write para: hex number
kparastrCALL prints
B " paragraphs",$00
RET ; "
CALL kpara ; WriteLn para
JMP xwriteln ; "
krdhex XOR AX,AX ; Read hex
krxlp PUSH AX ; save number
MOV.B AL,[BX] ; get char
CALL upcase ; UpCase
MOV.B CH,AL ; -> CH
POP AX ; restore number
SUB.B CH,#$30 ; ASCII-translation
JB krxend ; :< 0 - end
CMP.B CH,#$0A ; > 9 ?
JB krxok ; no: ok
SUB.B CH,#$07 ; A..F
CMP.B CH,#$0A ; < A ?
JB krxend ; yes: end
CMP.B CH,#$10 ; > F ?
JNB krxend ; yes: end
krxok MOV CL,#$04 ; number * 16
SHL AX,CL
OR.B AL,CH ; add digit
INC BX ; next char
JMP krxlp ; 'continue
krxend RET ; "
kfind CALL prints ; F:Find Error
B "Enter PC",$00
CALL kreadln ; ReadLn
JNZ kfind2 ; :ok
RET ; 'nothing entered
kfind2 CALL krdhex ; read hex
MOV errpos2,AX ; store error position
CALL knocode ; set flag: not compiled
kdofind CALL kgetfile ; get file, if necessary
MOV.B cpmode,#$01 ; set flag: searching
CALL prints
B $0D,$0A,"Searching",$00
JMP.b kcnofile ; "do it...
kcomp CALL kgetfile ; C:Compile - get file
CALL kdestfil ; set dest file
CALL prints
B $0D,$0A,"Compiling",$00
CMP.B cpmode,#$00 ; to memory ?
JZ kcnofile ; :yes
CALL prints
B " --> ",$00
MOV SI,#scrpn ; display dest path name
CALL printpn
kcnofileCALL xwriteln ; WriteLn
CALL turbo ; Call compiler
CMP.B cpmode,#$02 ; COM/CHN produced ?
JB kcnoerr ; :no
CMP.B cperr,#$00 ; error ?
JZ kcnoerr ; :no
CALL kdestfil ; set dest file
MOV AH,#$41 ; delete it
MOV DX,#destpn
CALL dos
kcnoerr CMP.B cperr,#$CA ; Compilation aborted ?
JNZ kcnoabrt ; :no
CALL xwriteln ; WriteLn
CALL xwriteln ; WriteLn
CALL vidattr2
CALL prints
B "Compilation aborted",$00
JMP kmainlp ; 'return to main menu
kcnoabrtCALL prints
B " lines",$0D,$0A,$0A,$00
CMP.B cperr,#$00 ; error ?
JNZ kctest ; :yes
CMP.B cpmode,#$01 ; find error pos ?
JZ kcnotfnd ; :yes
CALL kspace ; display space info
RET ; '
kcnotfndCALL vidattr3 ; error pos not found
CALL prints
B "Run-time error position not found",$00
CALL knrmvid
JMP.b kwlnret ; 'return to main
kctest CMP.B cperr,#$C9 ; I/O-error ?
JNZ kcfound ; :no
CALL ksfull ; write message
kwlnret CALL xwriteln ; WriteLn
JMP kmainlp ; 'return to main menu
kcfound CMP.B cperr,#$C8 ; Error pos found ?
JNZ kcerror ; :no
CALL prints
B "Run-time error position found",$00
JMP kcwend ; 'jump to this position
kcerror CALL vidattr3 ; Error message
CALL prints
B "Error ",$00
XOR AX,AX ; get error number
MOV AL,cperr
CALL knum1 ; write it
TEST.B msgflg,#$FF ; error msgs included ?
JZ kcwend ; :no
MOV BX,#txstrt ; pointer to messages
kcmsr MOV.B AL,[BX] ; get char
CMP AL,#$1A ; ^Z ?
JZ kcwend ; yes: not found
CMP AL,#$20 ; control char ?
JB kcmsr2 ; :yes
SUB AL,#$30 ; get digit
MOV.B AH,AL ; * 10
ADD.B AL,AL
ADD.B AL,AL
ADD.B AL,AH
ADD.B AL,AL
INC BX
ADD.B AL,[BX] ; get second digit
SUB AL,#$30 ; convert
INC BX ; next char
CMP.B AL,cperr ; = error number ?
JZ kcwmsg ; :yes
kcmsr2 MOV.B AL,[BX] ; get char
INC BX ; next one
CMP AL,#$0D ; end of line ?
JNZ kcmsr2 ; no: search it
INC BX ; next char: skip LF
JMP kcmsr ; 'continue searching
kcwmsg CALL prints ; Display error message
B ": ",$00
kcwlp MOV.B AL,[BX] ; get char
CMP AL,#$0D ; CR ?
JZ kcwend ; yes: done
CMP AL,#$20 ; control char ?
JNB kcwchar ; :no - write it
CMP AL,#$1A ; ^Z ?
JZ kcwend ; yes: done
MOV SI,#txstrt ; pointer to messages
kcsubsr MOV.B AL,[SI] ; get char
INC SI ; go to next
CMP AL,#$20 ; control char ?
JNB kcwsub ; no: search end of line
CMP.B AL,[BX] ; is it the right one ?
JNZ kcwsub ; :no, next line
kcsubsr2MOV.B AL,[SI] ; get char - write sub-message
CMP AL,#$0D ; CR ?
JZ kcwnext ; :end
CALL conput ; write it
INC SI ; next one
JMP kcsubsr2 ; 'continue
kcwsub MOV.B AL,[SI] ; search end of line
INC SI ; next char
CMP AL,#$0D ; CR ?
JNZ kcwsub ; :no
INC SI ; skip LF
JMP kcsubsr ; 'continue searching
kcwchar CALL conput ; display char
kcwnext INC BX ; go to next
JMP kcwlp ; 'continue
kcwend MOV.B mainflg,#$00 ; work file used
CMP.B inclflg,#$00 ; error in include file ?
JZ kcnoincl ; :no
MOV AL,#$2E
CALL conput ; write char
CALL knrmvid
CALL ksvnoask
MOV SI,#inclpn ; copy include file name
MOV DI,#workpn ; into work file name
CALL fncopy ; do it
CALL kwload ; load that file
CALL xwriteln ; WriteLn
CALL vidattr3
CALL prints
B "Error found in above include file",$00
JMP.b kcwait ; 'go into editor
kcnoinclCMP.B mainpn,#$00 ; main file exists ?
JZ kcwait ; :no
MOV SI,#mainpn ; copy main into
MOV DI,#workpn ; work file name
CALL fncopy ; do it
kcwait CALL waitesc ; wait for ESC
MOV BX,txerrpos ; get error pos in text
DEC BX
JMP editor2 ; "jump into editor
kmem MOV.B codedest,#$01 ; M:memory
RET ; "set flag
kcom MOV.B codedest,#$02 ; C:COM file
RET ; "set flag
kchn MOV.B codedest,#$03 ; H:CHN file
RET ; "set flag
kcs CALL prints ; O:CS size
B "Minimum Code Segment size",$00
CALL kreadln ; read it
MOV AX,#$0000 ; default
JZ kcsdef ; :nothing entered
CALL krdhex ; read hex
MOV BX,#$2D8B ; add runtime size
MOV CL,#$04 ; convert to paras
SHR BX,CL
ADD AX,BX
kcsdef MOV mincssz,AX ; store min CS
RET ; "
kds CALL prints ; D:DS size
B "Minimum Data Segment size",$00
CALL kreadln ; read it
MOV AX,#$0000 ; default
JZ kdsdef ; nothing entered: set it
CALL krdhex ; read hex
MOV BX,#$024F ; add std vars size
MOV CL,#$04
SHR BX,CL ; convert to paras
ADD AX,BX
kdsdef MOV mindssz,AX ; store min DS
RET ; "
kss CALL prints ; S:SS size
B "Minimum Stack Segment size",$00
CALL kreadln ; read it
MOV AX,#$0400 ; default: 16K
JZ kssdef ; nothing entered: set it
CALL krdhex ; read hex
kssdef MOV minhpsz,AX ; store min SS
RET ; "
kmss CALL prints ; A:Max. SS size
B "Maximum Stack Segment size",$00
CALL kreadln ; read it
MOV AX,#$A000 ; default: 640K
JZ kmssdef ; nothing entered: set it
CALL krdhex ; read hex
kmssdef MOV maxhpsz,AX ; store max SS
RET ; "
kparm CALL prints ; P:Parameter line
B "Parameters",$00
MOV SI,#parmlin ; ptr to buffer
CALL kreaddef ; Read line with default
MOV DI,#parmlin ; copy it
MOV CX,#$003B ; count
kparml MOV.B AL,[BX] ; get char
CMP AL,#$1A ; ^Z ?
JZ kparme ; yes: end
MOV.B [DI],AL ; store in buffer
INC BX ; next char
INC DI
LOOP kparml ; :another char
kparme MOV.B [DI],#$00 ; mark end of param line
RET ; "
kgetfileCMP.B workpn,#$00 ; load file, if necessary
JNZ kget1 ; :work file defined
CALL kgetfn ; get work file name
kget1 CMP.B mainpn,#$00 ; main file ?
kget2 MOV SI,#workpn
JNZ kget3 ; :work file exists
CALL kgetfn ; copy work -> main file name
MOV AL,#$00 ; use work file
JMP.b kget4 ; '
kget3 CALL kcmpfn ; work = main ?
JZ kget2 ; :yes
CALL ksvnoask ; save without question
MOV vfilbig,#flbigclr ; set error vectors
MOV vnewfil,#flescclr
MOV SI,#mainpn ; main file
CALL kwload2 ; load it
MOV AL,#$FF ; set flag: main file
kget4 MOV mainflg,AL ; store flag
MOV.B errio,#$00 ; clear error flag
RET ; "
kdestfilMOV SI,#mainpn ; Set dest file name
CMP.B [SI],#$00 ; main file name ok ?
JNZ kdsmain ; not null - ok
MOV SI,#workpn ; use work file name
kdsmain CALL fnsisc ; copy to scratch file name
MOV SI,#extcom ; set extension .COM
MOV AL,codedest
MOV.B cpmode,#$00 ; set flag: memory
DEC.B AL ; memory ?
JZ kdsmem ; :yes
MOV.B cpmode,#$02 ; flag: file
DEC.B AL ; COM ?
JZ kdsmem ; :yes
MOV.B cpmode,#$03 ; flag: CHN
MOV SI,#extchn ; set extension .CHN
kdsmem CALL kext ; modify file name
MOV DI,#destpn ; -> dest file name
CALL fnscdi ; copy it
RET ; "
krun CMP.B txcomp,#$00 ; R:Run
JNZ krok ; :already compiled
CALL kcomp ; compile it
krok CMP.B codedest,#$01 ; memory: ok
JZ krmem ; yes: do it
CMP.B codedest,#$02 ; COM-file ?
JNZ krchn
CALL xwriteln ; WriteLn
CALL vidattr2
CALL prints
B "Please Quit TURBO to run .COM file",$00
krchn JMP kmainlp ; 'return to menu
krmem MOV SI,#parmlin ; copy command line
MOV DI,#paramlin ; to start of CS
MOV ES,destseg ; seg of compiled program
XOR BX,BX ; clear offset
krparml MOV.B AL,[SI] ; get char
CMP AL,#$00 ; end ?
JZ krparme ; :yes
INC SI ; next char
INC BX
ES:
MOV.B [BX_DI],AL ; store that char
JMP krparml ; 'continue
krparme ES:
MOV.B [BX_DI]$01,#$0D ; store CR at the end
ES:
MOV.B [DI],BL ; store length
CALL prints
B $0D,$0A,"Running",$0D,$0A,$00
PUSH destseg ; CS of program
MOV AX,#$0100 ; start of program
PUSH AX
RETF ; 'start program
turboretES: ; return point from program
MOV AL,errio ; error ?
MOV errio,AL
ES:
MOV AX,errpos2 ; get error position
MOV errpos2,AX
MOV AX,#$FFFF ; flag
JMP kmeminit ; "reinit
kclrtxt MOV BX,txbeg ; Clear text
MOV txend,BX ; text beg -> text end
MOV.B txchg,#$00 ; text not changed
MOV.B mainflg,#$00 ; work file
knocode MOV.B txcomp,#$00 ; text not compiled
RET ; "
kquit CALL ksvchng ; Q:Quit - save changes
CALL xcrtexit ; CrtExit
MOV AH,#$4C ; end of process
JMP dos ; "return to MS-DOS
kgetfn CMP.B workpn,#$00 ; Get current file name
JNZ kgf2 ; :work file
CMP.B mainpn,#$00 ; main file ?
JNZ kgfmain ; :yes
CALL kwork ; set work file name
JMP.b kgf2 ; '
kgfmain MOV SI,#mainpn ; main -> work file name
MOV DI,#workpn
CALL fncopy
MOV.B mainflg,#$FF ; flag: main file
CALL kgetfn ; get filename
kgf2 CMP.B mainflg,#$00 ; main file ?
JZ kgfret ; :no
CALL ksvnoask ; save without question
CALL kwload ; load that file
kgfret RET ; "
kcmpfn MOV SI,#workpn ; main = work file ?
MOV DI,#mainpn
kcmpl MOV.B AL,[SI] ; get char
CMP.B AL,[DI] ; compare it
JNZ kcmpnoeq ; :not equal
OR.B AL,AL ; end ?
JZ kcmpret ; :yes
INC SI ; next char
INC DI
JMP kcmpl ; 'continue
kcmpnoeqMOV AL,#$01 ; set flag: false
kcmpret RET ; "
kreaderrMOV AX,#txstrt ; Read error message file
MOV txbeg,AX ; set text beg
MOV vnewfil,#flesc ; set error vectors
MOV vfilbig,#flbig
MOV SI,#errpath ; ptr to pathname
MOV DI,#scrpn ; scratch pathname
PUSH DI ; save ptr
PUSH DS ; DS -> ES
POP ES
PUSH CS ; CS -> DS
POP DS
CALL fncopy1 ; copy filename
PUSH ES ; ES -> DS
POP DS
POP SI ; restore ptr
CALL kwload2 ; load file
MOV BX,txend ; store its end position
MOV.B [BX],#$1A ; store ^Z at the end
INC BX ; next char
MOV txbeg,BX ; -> new text beg
RET ; "
kwstrsi PUSH BX ; write string [SI]
MOV BX,#prpnret ; no change
JMP.b prpn2 ; '
printpn PUSH BX ; write pathname: save BX
MOV BX,#upcase ; vector: UpCase
prpn2 CLD
LODS.B ; get char
OR.B AL,AL ; end ?
JZ prpne ; :no
CALL BX ; modify char
CALL conput ; write it
JMP prpn2 ; 'continue
prpne POP BX ; restore
prpnret RET ; "
knum1 XOR CX,CX ; write number - unformatted
CALL knum2 ; do it
RET ; "
knumax MOV CX,#$0005 ; write number - 5 digits
XOR DX,DX ; clear hi word
JMP.b knum2 ; '
knum2 XOR DX,DX ; write number DX:BX
knum PUSH SI ; save regs
PUSH DI
PUSH ES
PUSH DS ; DS -> ES
POP ES
PUSH CS ; CS -> DS
POP DS
MOV DI,#knumbuf ; dest buffer
MOV BX,AX ; number to write
PUSH CX ; save field size
CLD
XOR CX,CX ; format flag (leading zeroes)
MOV SI,#kndectab ; ptr decimal table
MOV AH,#$07 ; 7 digits
kndig XOR.B AL,AL ; clear digit
kndiglp INC.B AL ; count up
SUB BX,[SI] ; do successive subtraction
SBB DX,[SI]$02
JNB kndiglp ; :continue
ADD BX,[SI] ; restore number
ADC DX,[SI]$02
ADD SI,#$04 ; next table entry
DEC.B AL ; restore digit
JNZ knnot0 ; :not zero
OR CX,CX ; test flag
JZ knnoput
knnot0 ADD AL,#$30 ; convert to ASCII
STOS.B ; store in dest buffer
INC CX ; set flag
knnoput DEC.B AH ; another digit ?
JNZ kndig ; :yes
OR CX,CX ; digits done ?
JNZ knnot00 ; :yes
MOV AL,#$30 ; put a 0
STOS.B
INC CX ; digit count
knnot00 XOR AX,AX ; write a zero at the end
STOS.B
POP AX ; restore field size
PUSH ES ; ES -> DS
POP DS
SUB AX,CX ; fill up with spaces ?
JBE knnopad ; :no
INC CX ; space count
DEC DI
MOV SI,DI ; make space in buffer
ADD DI,AX
STD
REPZ ; move it up
MOVS.B
MOV CX,AX ; now fill with spaces
MOV AL,#$20
REPZ
STOS.B
knnopad MOV SI,#knumbuf ; buffer ptr
CALL kwstrsi ; write string
POP ES ; restore regs
POP DI
POP SI
RET ; "
kndectabW $4240,$000F ; 1000000 decimal table
W $86A0,$0001 ; 100000
W $2710,$0000 ; 10000
W $03E8,$0000 ; 1000
W $0064,$0000 ; 100
W $000A,$0000 ; 10
W $0001,$0000 ; " 1
kparse MOV CX,#$000F ; parse filename: no wildcards allowed
kparse2 MOV DI,#scrpn ; dest: scratch file name
MOV AX,[BX] ; get 2 chars: drive spec
CALL upcase ; UpCase
CMP AL,#$20 ; control char ?
JB kpdefdrv ; :yes
CMP.B AH,#$3A ; : ?
JNZ kpdefdrv ; :no
INC BX ; next char
INC BX
JMP.b kpdrv ; 'set drive
kpdefdrvMOV AH,#$19 ; get default drive
CALL dos
ADD AL,#$41 ; -> ASCII
MOV AH,#$3A
kpdrv MOV [DI],AX ; store drive spec
INC DI
INC DI
OR.B CH,CH ; test path ?
JNZ kpendpn2 ; :no
CMP.B [BX],#$5C ; \ ?
JZ kpendpn2 ; :yes
MOV.B [DI],#$5C ; store \
INC DI
MOV AH,#$47 ; get current path
MOV.B DL,AL ; drive number
SUB.B DL,#$40
MOV SI,DI ; destination
CALL dos ; do it
JB kpendpn2 ; :error
CMP.B [DI],#$00 ; search end of path
JZ kpendpn2 ; :found
kpendsr MOV.B AL,[DI] ; get char
OR.B AL,AL ; end ?
JZ kpendpn ; :found
INC DI ; next char
CMP DI,#scrpnend ; end of buffer ?
JB kpendsr ; :not yet
JMP.b kpend ; 'end it
kpendpn MOV.B [DI],#$5C ; store \
INC DI ; next char
CMP DI,#scrpnend ; end of buffer ?
; :yes
JZ kpend
kpendpn2XOR.B CH,CH ; clear flag
PUSH CS ; CS -> ES
POP ES
CLD
kpchklp MOV.B AL,[BX] ; get char
CMP AL,#$20 ; control / space ?
JBE kpend ; :yes
PUSH CX ; save cnt, dest ptr
PUSH DI
MOV DI,#kpinval ; test: illegal char ?
REPNZ ; CL is count for this search
SCAS.B ; search char in table
POP DI ; restore
POP CX
JZ kpend ; found: end it
INC BX ; next char
MOV.B [DI],AL ; store it
INC DI ; next char in dest
CMP DI,#scrpnend ; end of buffer ?
JB kpchklp ; :no
kpend MOV.B [DI],#$00 ; mark end
RET ; "
kpinval B $22,"+,/ ; <=>[]{|}*?" "table of illegal chars
kpasext MOV SI,#extpas ; pointer: .PAS
kextdef PUSH SI ; save extension ptr
CALL kparse ; parse filename
POP SI ; restore ext ptr
MOV DL,#$01 ; only set if no ext
JMP.b kx1 ; 'do it
kext2 MOV DL,#$02
JMP.b kx1 ; '
kext XOR.B DL,DL ; set file extension
kx1 MOV DI,#insline2 ; ptr scratch file name
XOR CX,CX ; clr dot pos
kxsrdot MOV.B AL,[DI] ; get char
OR.B AL,AL ; end ?
JZ kxend ; :yes
INC DI ; next one
CMP.B DL,#$02 ; search dot ?
JZ kxsrdot ; :no
CMP AL,#$2E
JNZ kxnodot ; :no
MOV CX,DI ; store pos of dot
kxnodot CMP AL,#$5C ; \ ?
JNZ kxsrdot ; :no
XOR CX,CX ; clear dot pos
JMP kxsrdot ; 'continue
kxend OR CX,CX ; test dot pos
JZ kxnodotf ; :not set
OR.B DL,DL ; set extension ?
JNZ kxret ; :no
MOV DI,CX ; dot position
DEC DI ; go back
kxnodotfCS: ; set extension
MOV.B CL,[SI] ; length of extension
XOR.B CH,CH ; -> count
JCXZ kxexte ; :nothing to do
kxextl CMP DI,#scrpnend ; buffer end ?
JZ kxexte ; :yes
INC SI ; next pos
CS:
MOV.B AL,[SI] ; get ext char
MOV.B [DI],AL ; store it
INC DI ; next one
LOOP kxextl ; :another char
kxexte MOV.B [DI],#$00 ; mark end
kxret RET ; "
fnscdi MOV SI,#scrpn ; copy scratch -> [DI]
JMP.b fncopy ; '
fnsisc MOV DI,#scrpn ; copy [SI] -> scratch
fncopy PUSH DS ; DS -> ES
POP ES
fncopy1 MOV CX,#$0020 ; copy 64 bytes
CLD
REPZ
MOVS ; do it
RET ; "
kwscrpn MOV SI,#scrpn ; write scratch file name
JMP printpn ; "
kwworkpnMOV SI,#workpn ; write work file name
JMP printpn ; "
kdworkfnMOV SI,#workpn ; Display work file name
PUSH DS ; DS -> ES
POP ES
CLD
LODS.B ; get char
CALL upcase ; UpCase
CALL conput ; write it (drive)
LODS.B ; get char
CALL conput ; write it (:)
MOV DI,SI ; search end of filename
XOR.B AL,AL
MOV CX,#$FFFF ; any length
CLD
REPNZ
SCAS.B ; search it
STD ; backward search !
MOV AL,#$5C ; now search \
MOV CX,#$FFFF ; any length
DEC DI
REPNZ
SCAS.B ; do it
MOV SI,DI ; position of file name
INC SI ; without dir path
INC SI
JMP printpn ; "write it
printattPUSH BP ; Print string with highlighting
MOV BP,SP ; string: inline, 0=end
XCHG BX,[BP]$02 ; get return addr
PUSH AX ; save
PUSHF
pralp CS: ; get char
MOV.B AL,[BX]
INC BX ; go to next
OR.B AL,AL ; end ?
JZ praend ; :yes
CMP AL,#$80 ; highlighted ?
JNB prahi ; :yes
CALL klowvid ; LowVideo
JMP.b pralo ; 'write it
prahi CALL knrmvid ; NormVideo
AND AL,#$7F ; mask out bit 7
JZ pralp ; zero: end
pralo CALL conput ; write it
JMP pralp ; 'next char
praend POPF ; restore
POP AX
XCHG BX,[BP]$02 ; restore ret
POP BP
RET ; "
knrmvid CMP.B curatt,#$00 ; NormVideo
JZ knrmret ; already set: ret
MOV.B curatt,#$00 ; set flag
JMP xnormvid ; 'do it
knrmret RET ; "
klowvid CMP.B curatt,#$01 ; LowVideo
JZ knrmret ; :already set
MOV.B curatt,#$01 ; set it
JMP xlowvid ; "
vidattr3CMP.B curatt,#$03 ; Attribute #3
JZ knrmret ; :already set
MOV.B curatt,#$03 ; set it
PUSH AX ; save
MOV AL,att3 ; set that attribute
MOV attcur,AL
POP AX ; restore
RET ; "
vidattr2CMP.B curatt,#$02 ; Attribute #2
JZ knrmret ; :already set
MOV.B curatt,#$02 ; set it
PUSH AX ; save
MOV AL,att2 ; set that attribute
MOV attcur,AL
POP AX ; restore
RET ; "
movebk MOV SI,BX ; Block transfer [BX]->[DX]
MOV DI,DX ; forward = delete
PUSH DS ; DS -> ES
POP ES
CLD
REPZ ; CX=count
MOVS.B ; do it
MOV BX,SI ; point to block end
MOV DX,DI
RET ; "
movebkb MOV SI,BX ; Block transfer [BX]->[DX]
MOV DI,DX ; backward = insert
PUSH DS ; DS -> ES
POP ES ; BX,DX point to block END !
STD
REPZ
MOVS.B ; do it
CLD ; reset dir flag
MOV BX,SI ; point to block beg
MOV DX,DI
RET ; "
inited XOR AX,AX ; Init editor vars
MOV editflg,AL
MOV DI,#srend ; 390..3B0:=0
MOV CX,#$0021
PUSH DS ; DS -> ES
POP ES
CLD ; fill
REPZ
STOS.B
INC AX ; 3B1..3B2:=1
MOV DI,#oldlen ; old len, redisplay from
MOV CX,#$0002
REPZ
STOS.B
INC AX ; Words 3BA..3BD:=2
MOV DI,#bkbegl ; block pos in buffer
MOV CX,#$0002
REPZ
STOS
MOV AX,#$FFFF ; 3B3..3B8:=FF
MOV DI,#overflg ; set flags:
MOV CX,#$0006 ; insert, indent, display
REPZ ; redisplay
STOS.B
MOV AX,#line ; Words 3BE..3C8:=046C
MOV DI,#edpos ; current pos, pos in line buffer
MOV CX,#$0006 ; pos FIFO = beg of line buffer
REPZ
STOS
MOV AL,#$00 ; 3CA..45F:=0
MOV DI,#cmdbuf ; command entry buffer, search,
MOV CX,#$0096 ; replace, option, filename
REPZ
STOS.B
MOV.B cmdbuf,#$03 ; command buf: 3 chars
MOV.B srword,#$1E ; search word: 30 chars
MOV.B srrepl,#$1E ; replce word: 30 chars
MOV.B stopt,#$0A ; option word: 10 chars
MOV.B fnbuf,#$40 ; file name: 64 chars
MOV.B fnbufend,#$1A ; end file name buffer
MOV lineend,#$0A0D ; end line input buffer
MOV AL,#$00 ; no flicker
MOV DX,#$B000 ; mono screen segment
CMP.B scrmod,#$07 ; mode = 7 ?
JZ inited1 ; yes: mono
CS:
MOV AL,scrflick ; get flicker flag
MOV DH,#$B8 ; set segment
inited1 MOV scrbad,AL ; store flicker flag
MOV scrseg,DX ; store segment
RET ; "
clred MOV bkbeg,BX ; Clear editor vars
MOV bkend,BX ; set to beg of text = BX
MOV edpos,BX
MOV posfifo,BX
MOV qppos,BX
MOV disbeg,BX
RET ; "
ekd CALL eflush ; flush changes
CS:
MOV.B DL,txwiny2 ; bottom-1
DEC.B DL
MOV DH,#$00
CALL setcpos ; set cursor pos
CALL knrmvid ; NormVideo
DEC txend ; end of text
MOV BX,txend
MOV.B [BX],#$1A ; store ^Z at the end
JMP kmainlp ; "return to main menu
editor CALL kgetfn ; E:Editor - get file name
MOV BX,#$FFFF ; position flag
editor2 PUSH BX ; save pos
MOV BX,txend ; end of text
MOV [BX],#$0A0D ; store CR,LF there
INC txend
MOV.B statobs,#$00 ; status line obsolete
MOV.B dislin,#$01 ; redisplay all
MOV sepptr,#eseptab ; pos of word separator tab
CALL knrmvid ; NormVideo
CALL xclrscr ; ClrScr
POP BX ; relative text pos
ADD BX,txbeg ; +text beg+1
INC BX
CALL efsetpos ; set new pos
edmain CALL eredispl ; redisplay
MOV.B CL,statera ; clear status line
OR.B CL,CL ; anything to erase ?
JZ ednoera ; :no
MOV BX,#$0000 ; cursor pos: home
CALL esetcur
CALL esetlow ; LowVideo
MOV AL,#$20 ; space
edera CALL ewritch ; write char
DEC.B CL ; another ?
JNZ edera ; :yes
MOV.B statera,CL ; clear erase flag
ednoera CALL estat ; display status line
CALL edproc ; get command
JNB edchg ; :no command - enter char
JZ edmain ; :not found
CMP.B DH,#$7F ; MSB vector = 1 ?
JB ednochg ; :no
MOV.B txchg,#$FF ; set flag: text changed
MOV.B txcomp,#$00 ; code invalid
AND.B DH,#$7F ; mask vector
ednochg MOV BX,#edmain ; store return addr
PUSH BX ; -> main loop
PUSH DX
MOV BX,#pfifosrc ; do position FIFO
MOV DX,#pfifodst
MOV CX,#$0008 ; 8 bytes
JMP movebkb ; 'move back, jump to command
eprefix CALL eddiscmd ; ^P:Control char prefix - display
CALL keyget ; get char
JMP.b edput ; 'enter this char
edchg MOV txchg,AL ; flag: text changed
MOV.B txcomp,#$00 ; code invalid
edput MOV BX,lnpos ; pos in line
CMP BX,#lineend0 ; line full ?
JNB edmain ; yes: ignore char
CMP.B overflg,#$00 ; overwrite ?
JZ edover ; :yes
PUSH AX ; save it
CALL einsch ; make space for char
POP AX ; restore it
edover MOV.B [BX],AL ; store char
INC BX ; cursor right
PUSH BX
CALL eredlin ; redisplay line
POP BX
MOV lnpos,BX ; new pos in line buffer
CALL erepos ; reposition in line
JMP edmain ; "main loop
edproc CALL keyget ; Get command: get key
CMP AL,#$7F ; Delete ?
JZ edpdel ; :yes
CMP AL,#$20 ; control char ?
JNB edpret ; no: no command
edpdel MOV BX,#cmdbuf ; pointer to cmd buf
MOV.B [BX],#$01 ; store length
INC BX
MOV.B [BX],AL ; store char
edploop PUSH BX ; save pos in buf
MOV BX,#cmdbuf ; ptr cmd buf
MOV SI,#ecmd1 ; ptr first cmd table
MOV CH,#$FF ; must be equal
CALL edsrcmd ; search in table
POP BX ; restore pos
OR.B AL,AL ; test result
JNZ edpfnd ; :found
PUSH BX ; save again
MOV BX,#cmdbuf ; ptr cmd buf
MOV SI,#ecmd2 ; ptr second cmd table
MOV CH,#$1F ; second char without ctrl ok
CALL edsrcmd ; search in table
POP BX ; restore pos
OR.B AL,AL ; test result
STC
JZ edpret ; :not found
edpfnd DEC.B AL
JZ edpcont ; :need another key
MOV BX,#ejmptab ; ptr jump table
ADD BX,CX ; +2*cmd number
ADD BX,CX
CS:
MOV DX,[BX] ; get jump addr
STC ; ok
edpret RET ; '
edpcont CALL eddiscmd ; display command char
PUSHF ; save stat
CALL keyget ; get key
INC.B cmdbuf ; inc lenght cmd buf
INC BX ; next pos
MOV.B [BX],AL ; store char
POPF ; restore stat: function key ?
JNZ edploop ; :continue
CALL eddiscmd ; display
JMP edploop ; "try it again
eddiscmdCALL ekbdstat ; display command sequence
JNZ edpret ; late - ret
PUSH BX ; save pos
XOR BX,BX ; clear char count
MOV.B statera,BL ; number of chars to erase
CALL esetcur ; set position: home
MOV BX,#cmdbuf ; ptr cmd buf
MOV.B AL,[BX] ; get cmd length
eddislp PUSH AX ; save len
INC BX ; next char
MOV.B AL,[BX] ; get char
ADD.B statera,#$02 ; 2 chars to erase
CALL edcntput ; put char
POP AX ; restore len
DEC.B AL ; another char ?
JNZ eddislp ; :yes
POP BX ; restore
RET ; "
edcntputPUSH AX ; Display control code - save char
CALL esetnrm ; set attribute
POP AX ; restore char
CMP AL,#$20 ; control ?
JB edcntl ; :yes
JMP ewritch ; 'write char
edcntl PUSH AX ; save char
PUSH AX
MOV AL,#$5E ; write ^
CALL ewritch
POP AX ; restore char
ADD AL,#$40 ; -> normal char
CALL ewritch ; write it
POP AX ; restore char
RET ; "
edsrcmd MOV CL,#$FF ; Search command in table
PUSH CX ; save cmd comparison mask
PUSH BX ; command buf ptr
edsclp POP BX ; restore
POP CX
CS:
MOV.B AL,[SI] ; get char from table
INC SI ; next pos
OR.B AL,AL ; end of table ?
JZ edscret ; :yes
INC.B CL ; command number
PUSH CX ; save
PUSH BX
MOV.B CL,[BX] ; get command len
INC BX ; go to first char
SUB.B AL,CL ; >= table len ?
JNB edsc1 ; :yes
ADD.B CL,AL ; skip this entry
JMP.b edscnxt1 ; 'try next one
edsc1 LAHF ; save flags
PUSH AX ; save table entry length
edsccmp CS:
MOV.B AL,[SI] ; char from table
SUB.B AL,[BX] ; compare them
AND.B AL,CH ; mask difference
JNZ edscnext ; :not equal - next one
INC SI ; next char
INC BX
DEC.B CL ; = length of cmd ?
JNZ edsccmp ; no: compare
POP AX ; restore flag, table entry length
SAHF
POP BX ; restore
POP CX
MOV CH,#$00 ; mode: none
MOV AL,#$FF ; found
JZ edscret ; :found
MOV AL,#$01 ; need another char
edscret RET ; '
edscnextPOP AX ; restore length
ADD.B AL,CL ; skip entry
MOV.B CL,AL
edscnxt1MOV CH,#$00 ; clr hi
ADD SI,CX ; add to ptr
JMP edsclp ; "try next one
estat CALL ekbdstat ; Display status line: Get KBD stat
JNZ edscret ; late: ret
CALL klowvid ; LowVideo
CMP.B statobs,#$FF ; obsolete ?
JZ estnrm ; no:just display pos
MOV.B statobs,#$FF ; clear flag
MOV BX,#$0000 ; screen position
MOV oldpos,BX ; remember cursor pos
MOV.B edcol,BL ; column
CALL esetcur ; set cursor pos
CALL eclrlin ; clear line
CS:
CMP.B txwinx2,#$38 ; screen width sufficient ?
JB estshrt ; :no
MOV BX,#$2A00 ; set cursor pos
CALL esetcur
CALL kdworkfn ; display filename
estshrt MOV BX,#$0600 ; cursor pos
CALL ewritpos ; put string
B "Line ",$00
MOV BX,#$1000 ; cursor pos
CALL ewritpos ; put string
B "Col ",$00
MOV BX,#$1800 ; cursor pos
CMP.B overflg,#$00 ; Overwrite ?
JZ estover ; :yes
CALL ewritpos ; put string
B "Insert ",$00
JMP.b estins ; '
NOP
estover CALL ewritpos ; put string
B "Overwrite ",$00
estins CMP.B indntflg,#$00 ; Indent ?
JZ estnrm ; :no
CALL ewrits ; put string
B "Indent",$00
estnrm MOV AL,horscr ; calc column
ADD.B AL,phcol
INC.B AL
CMP.B AL,edcol ; = old col ?
JZ estnocol
MOV edcol,AL ; set that column
MOV BX,#$1400 ; cursor pos
CALL esetcur ; set it
CALL klowvid ; LowVideo
MOV.B BL,AL ; number -> BX
MOV BH,#$00 ; clr hi
MOV AL,#$03 ; 3 chars
CALL ednum ; display number
estnocolMOV BX,edpos ; current pos = old pos ?
CMP BX,oldpos
JNZ estrow ; no: display line number
JMP eposcur ; 'restore cursor pos
estrow CALL eposcur ; restore cursor pos
CALL ekbdstat ; Get KBD stat
JNZ estend
MOV DI,txbeg ; beg of text
MOV CX,edpos
MOV DX,#$0001 ; line number
SUB CX,DI ; calc count
JZ estrow2 ; :done
estcnt CLD ; forward search
PUSH DS ; DS -> ES
POP ES
estlf MOV AL,#$0A ; search LF
REPNZ
SCAS.B
JNZ estrow2 ; :not found, done
INC DX ; count it
OR.B DL,DL ; 256 lines counted ?
JNZ estlf ; :no, continue
CALL ekbdstat ; Get KBD stat
JZ estcnt ; :nothing entered
JMP.b estend
estrow2 MOV BX,#$0B00 ; cursor pos
PUSH DX ; save line number
CALL esetcur ; set cursor pos
CALL klowvid ; LowVideo
POP BX ; restore number
MOV AL,#$05 ; 5 digits
CALL ednum ; write it
MOV BX,edpos ; current pos -> old pos
MOV oldpos,BX
estend JMP eposcur ; "restore cursor pos
ednum PUSH AX ; Write number: save field length
MOV CH,#$00 ; clear flag
CALL edcvt ; convert number
POP AX ; restore length
ADD.B AL,CH ; counter
JZ ednret ; :done
; counter
MOV.B CH,AL
MOV AL,#$20 ; pad with spaces
ednpad CALL ewritch ; put it
DEC.B CH ; another ?
JNZ ednpad ; :yes
ednret RET ; "
edcvt CMP BX,#$00 ; number -> decimal
MOV AL,#$30
JZ edcvno0 ; 0: store a 0
MOV DX,#$2710 ; digit 10000
CALL edcvdig
MOV DX,#$03E8 ; digit 1000
CALL edcvdig
MOV DX,#$0064 ; digit 100
CALL edcvdig
MOV DX,#$000A ; digit 10
CALL edcvdig
MOV DX,#$0001 ; digit 1
edcvdig XOR.B AL,AL ; clear digit
edcvdlp SUB BX,DX ; do successive subtraction
JB edcvput ; :done
INC.B AL ; count digit
JMP edcvdlp ; '
edcvput ADD BX,DX ; restore number
ADD AL,#$30 ; convert to ASCII
CMP AL,#$30 ; 0 ?
JNZ edcvno0 ; :no
OR.B CH,CH ; is it a leading zero ?
JZ ednret
edcvno0 DEC.B CH ; set flag
JMP ewritch ; "write char
edreadstCALL prints ; Input from status line
B ": ",$00
MOV BX,DX ; destination ptr
MOV SI,DX
INC BX ; point to string
MOV.B DH,[BX] ; get old length
MOV.B [BX],#$00 ; clr old length
INC BX ; go to string
erloop MOV.B disflg,#$00 ; flag: editing stat line
PUSH DX ; save regs
PUSH BX
PUSH SI
CALL edproc ; process key
POP SI
POP BX
POP DX
MOV.B disflg,#$FF ; restore flag
JNB erput ; no command: put char
JNZ ercr ; :valid command
MOV AL,cmdbuf1 ; get command
CALL etstint ; test for interrupt
JMP erloop ; 'loop back
ercr MOV.B AL,CL ; command code
CMP AL,#$00 ; CR ?
JNZ errt ; :no
MOV.B [BX],#$1A ; store ^Z at the end
RET ; 'return
errt CMP AL,#$03 ; Character right ?
JNZ errecall ; :no
MOV.B AL,[SI]$01 ; get length
CMP.B AL,DH ; = pos ?
JNB erloop
INC.B [SI]$01 ; go right
JMP.b errest ; 'get char from old value
errecallCMP AL,#$05 ; word right ?
JNZ erclr ; :no
errec1 MOV.B AL,[SI]$01 ; length = old len ?
CMP.B AL,DH
JZ erloop ; yes: loop
MOV.B AL,[BX] ; get char
CALL edcntput ; write it
INC BX ; next one
INC.B [SI]$01 ; inc len
JMP errec1 ; 'until end
erclr CMP AL,#$04 ; Word left ?
JNZ erprefix ; :no
erclrl CALL erdelc ; delete char
JNZ erclrl ; :ok, continue
JMP erloop ; 'end reached, loop
erprefixCMP AL,#$2D ; Control char prefix ?
JNZ erdel ; :no
CALL keyget ; get a key
JMP.b erput ; 'put it
erdel CMP AL,#$1B ; Test delete codes
JZ erdel1 ; :delete left
CMP AL,#$1C
JZ erdel1 ; :del left
CMP AL,#$01
JZ erdel1 ; :char left
CMP AL,#$02
JNZ erinv ; :no delete
erdel1 CALL erdelc ; delete char
JMP erloop ; 'loop back
erinv CMP.B cmdbuf1,#$12 ; word right ?
JZ errec1 ; :yes
JMP erloop ; 'loop back
erput MOV.B DL,AL ; save char
MOV.B AL,[SI]$01 ; current len
CMP.B AL,[SI] ; < max len ?
JB erput2 ; :ok
JMP erloop ; 'loop back
erput2 INC.B [SI]$01 ; inc length
MOV.B [BX],DL ; store char
errest MOV.B AL,[BX] ; get char
INC BX ; go to next
CALL edcntput ; display it
MOV.B AL,[SI]$01 ; get current len
CMP.B AL,DH ; = old len ?
JNB ergend ; :no
JMP erloop ; 'loop back
ergend MOV.B DH,[SI]$01 ; get pos
JMP erloop ; 'loop back
erdelc MOV.B AL,[SI]$01 ; Delete char: get len
OR.B AL,AL ; 0 ?
JZ erdelret ; yes: nothing to delete
DEC.B [SI]$01 ; dec length
DEC BX ; go back one char
CMP.B [BX],#$20 ; was it a control char ?
JNB erdelcc ; :no
CALL erdelcc ; delete two chars
erdelcc CALL prints ; delete one char
B $08," ",$08,$00
MOV AL,#$FF ; set flag
OR.B AL,AL
erdelretRET ; "
efind MOV.B srmode,#$00 ; ^QF:Find - set mode flag
CALL eqffind ; get find word
CALL eqfopt ; get option string
JMP.b efnd1 ; "do it
eqffind CALL eclrstat ; Get find word: clear stat line
CALL ewrits ; write string
B "Find",$00
MOV DX,#srword ; dest: find word
JMP edreadst ; "read string
eqfrepl CALL eclrs2 ; Get repl word: clear stat line
CALL ewrits ; write string
B "Replace with",$00
MOV DX,#srrepl ; dest var
JMP edreadst ; "read string
eqfopt CALL eclrs2 ; Get Options: clear stat line
CALL ewrits ; write string
B "Options",$00
MOV DX,#stopt ; dest var
CALL edreadst ; read string
CS:
MOV.B BH,txwinx2 ; end of screen
DEC.B BH
MOV BL,#$00 ; beg of line
JMP esetcur ; "set cursor pos
ereplaceMOV.B srmode,#$FF ; ^QA:Search & Replace
CALL eqffind ; get find word
CALL eqfrepl ; get replacement word
CALL eqfopt ; get option string
JMP.b efnd1 ; "do it
erepeat CALL eddiscmd ; ^L:Repeat last find
efnd1 CALL eflush ; write back current line
CALL esrcend ; end of line buffer
INC BX ; +1
MOV DX,lnpos ; or current pos in line
CALL emin
MOV DX,#line ; - beg of buffer
SUB BX,DX
MOV DX,edpos ; + current pos
ADD BX,DX
MOV srpos,BX ; -> search pos
MOV srcnt,#$0000 ; line count
MOV CX,txend ; text end-1
DEC CX
MOV srend,CX ; -> search end
MOV CX,txbeg ; text beg -> search beg
MOV srbeg,CX
MOV BX,#sropt1 ; ptr option string
MOV.B CH,[BX] ; get length
MOV.B sropt,#$00 ; clear option flag
OR.B CH,CH ; empty ?
JNZ efndcnt ; :no
JMP.b efndopte ; 'no options set
NOP ; Process option line
efndcnt INC BX ; next char
MOV.B AL,[BX] ; get char
CMP AL,#$30 ; valid digit ?
JB efndopt ; :no
CMP AL,#$3A ; > 9 ?
JNB efndopt ; :no digit
SUB AL,#$30 ; -> number. Get line count
CBW
PUSH AX ; save digit
MOV AL,#$0A ; current count * 10
IMUL srcnt
POP DX ; + digit
ADD AX,DX
MOV srcnt,AX ; -> line count
JMP.b efndo2 ; 'continue
efndopt CALL upcase ; UpCase
CMP AL,#$57 ; W ?
JNZ efndu ; :no
OR.B sropt,#$01 ; flag: whole words
efndu CMP AL,#$55 ; U ?
JNZ efndn ; :no
OR.B sropt,#$04 ; flag: ignore upper/lower
efndn CMP AL,#$4E ; N ?
JNZ efndg ; :no
OR.B sropt,#$02 ; flag: replace without asking
efndg CMP AL,#$47 ; G ?
JNZ efndb ; :no
OR.B sropt,#$08 ; flag: global
efndb CMP AL,#$42 ; B ?
JNZ efndl ; :no
OR.B sropt,#$10 ; flag: backwards
efndl CMP AL,#$4C ; L ?
JNZ efndo2 ; :no
OR.B sropt,#$20 ; flag: search block
AND.B sropt,#$F7 ; clear global
MOV CX,bkend ; search block, only
MOV srend,CX ; block end -> search end
MOV CX,bkbeg ; block beg -> search beg
MOV srbeg,CX
efndo2 DEC.B CH ; another option char ?
JNZ efndcnt ; :yes
efndopteCMP srcnt,#$01 ; at least one line to do
JA efndcnok ; :ok
MOV srcnt,#$0001
efndcnokMOV BX,srbeg ; begin limit
MOV AL,sropt ; option
TEST AL,#$10 ; backwards ?
JZ efndfwd ; :no
MOV BX,srend ; end limit
efndfwd TEST AL,#$28 ; block & global ?
JNZ efndrep ; :no
MOV BX,srpos ; current pos
efndrep MOV srpos,BX ; store search pos
TEST.B sropt,#$10 ; backwards ?
JNZ efndbkw ; :yes
CMP BX,srend ; = search limit ?
JB efndsrc ; :no, continue
JMP efndexit ; 'done
efndbkw DEC BX ; go back
CMP BX,srbeg ; = search limit ?
JNB efndsrc ; :no
JMP efndexit ; 'end it
efndsrc MOV DX,#srword2 ; ptr searched word
MOV AL,srword1 ; get length
MOV.B CH,AL
TEST.B sropt,#$10 ; backwards ?
JZ efndfw2 ; :no
DEC.B AL ; go to its end
ADD.B AL,DL
MOV.B DL,AL
JNB efndfw2
INC.B DH
efndfw2 TEST.B sropt,#$01 ; whole words ?
JZ efndall1 ; :no
PUSH DX ; save
PUSH BX
CALL edbeg ; at the beginning ?
MOV.B AL,[BX] ; get char
POP BX ; restore
POP DX
JB efndall1 ; :at beg
CALL edfnchar ; is it alphanum ?
JB efndpos ; :yes - continue searching
efndall1OR.B CH,CH ; length = 0 ?
JZ efndnil ; :found
efndcmp CALL edcmp ; compare chars
JNZ efndpos ; :not the same
DEC.B CH ; another char ?
JNZ efndnch ; :yes
efndnil TEST.B sropt,#$01 ; whole words ?
JZ efndall2 ; :no
PUSH BX ; save
CALL edend ; end ?
MOV.B AL,[BX] ; get char
POP BX ; restore
JB efndall2 ; :at the end
CALL edfnchar ; alphanum ?
JB efndpos ; yes: not valid
efndall2TEST.B sropt,#$10 ; backwards ?
JNZ efndbw2 ; :yes
INC BX ; end of text ?
CMP BX,txend
efndbw2 CMP.B srmode,#$00 ; search mode ?
JZ efndfnd ; :find
CALL edoreplc ; replace it
efndfnd TEST.B sropt,#$28 ; block global ?
JZ efndnxt ; :yes
JMP efndrep ; 'continue
efndnxt DEC srcnt ; another line to process ?
JZ efndend ; :no
JMP efndrep ; 'continue
efndend JMP.b efsetpos ; 'set new pos
NOP
efndnch PUSH DX ; save pos
CALL edend ; at the end ?
POP DX ; restore
JB efndexit ; :yes
TEST.B sropt,#$10 ; backwards ?
JZ efndfw3 ; :no
DEC DX ; go back
JMP efndcmp ; '
efndfw3 INC DX ; next char
JMP efndcmp ; 'continue
efndpos MOV BX,srpos ; get current search pos
CALL edend ; at the end ?
JB efndexit ; :yes
JMP efndrep ; 'continue
efndexitCALL edrange ; end search: limit new pos
CALL efsetpos ; set pos
TEST.B sropt,#$28 ; global block ?
JNZ espret ; :no
CALL eclrstat ; clear status line
CALL ewriterr ; write string
B "Search string not found",$00
JMP waitesc ; "wait for ESC
efsetposCALL esetpos ; set position
JMP erstlin ; "restore line
esetpos MOV DX,txend ; Set pos
DEC DX ; text end - 1
CMP BX,DX ; = current ?
JB esp2 ; :below
XCHG BX,DX ; limit it
esp2 PUSH BX ; save
PUSH BX
CALL esrcbeg ; search beg of that line
MOV edpos,BX ; -> current pos
XCHG BX,DX ; -> DX
POP BX ; restore
SUB BX,DX ; calc pos in line
MOV DX,#line ; + buffer offset
ADD BX,DX
MOV lnpos,BX ; -> pos in line buffer
CALL erepos ; reposition in current line
CALL eseldisp ; do selective rewrite
POP BX ; restore pos
espret RET ; "
edrange MOV DX,txbeg ; bring BX into range:
CALL emin ; >= text beg,
MOV BX,txend
DEC BX
JMP emin ; "< text end
edfncharCMP AL,#$30 ; char in alphanum ?
JB edfnch2 ; <0: no
CMP AL,#$3A
JB edfnchrt ; 0..9: yes
CMP AL,#$41
JB edfnch2 ; <A: no
CMP AL,#$5B
JB edfnchrt ; A..Z: yes
CMP AL,#$61
JB edfnch2 ; <a: no
CMP AL,#$7B
JB edfnchrt ; a..z: yes
edfnch2 OR.B AL,AL ; test flag
RET ; "
edbeg TEST.B sropt,#$10 ; At the beginning ?
JZ edend2 ; :forward
edbeg2 INC BX
CMP BX,srend ; = search limit end ?
CMC
edfnchrtRET ; '
edend TEST.B sropt,#$10 ; end reached ?
JZ edbeg2 ; :forward
edend2 DEC BX
CMP BX,srbeg ; = search limit beg ?
RET ; "
edcmp XCHG DX,BX ; Compare chars
MOV.B AL,[BX] ; get char in search string
XCHG DX,BX
CMP AL,#$01 ; wild card ?
JZ edfnchrt ; yes: ok
CMP.B AL,[BX] ; compare it
JZ edfnchrt ; yes: ok
TEST.B sropt,#$04 ; ignore upper/lower ?
JZ edcmp2 ; :no, just compare
CALL edfnchar ; is it a valid char ?
JNB edcmp2 ; :no
XOR.B AL,[BX] ; mask different bits
AND AL,#$DF
RET ; '
edcmp2 CMP.B AL,[BX] ; compare it
RET ; "
edoreplcPUSH BX ; Do replace
CALL ekbdstat ; get KBD stat
JZ erpdis ; nothing: display it
TEST.B sropt,#$02 ; replace without asking ?
JNZ erpdoit ; :yes
erpdis CALL efsetpos ; set new position
CALL eredispl ; redisplay
TEST.B sropt,#$02 ; replace without asking ?
JNZ erpdoit ; :yes
CALL eclrs2 ; clear status line
CALL printatt ; write string
B "Replace (",$D9,"/",$CE,"): ",$00
erpblnk MOV.B BL,phrow ; Blink cursor: alternate
MOV.B BH,phcol ; status line / cursor pos
CALL esetcur ; set cursor pos
MOV CX,#$0004 ; do 4 times
erpbw1 CALL ekbdstat ; get KBD stat
JNZ erpbw2 ; :key pressed
MOV BX,#$0064 ; wait 100 ms
PUSH CX ; save count
CALL delaybx ; Delay
POP CX ; restore
LOOP erpbw1 ; :another
MOV BX,#$0F00 ; pos:status line
CALL esetcur ; set cursor pos
MOV CX,#$0004 ; 4 times
erpblnk2CALL ekbdstat ; get KBD stat
JNZ erpbw2 ; :key pressed
MOV BX,#$0064 ; wait 100 ms
PUSH CX ; save cnt
CALL delaybx ; Delay
POP CX ; restore cnt
LOOP erpblnk2 ; :another
JMP erpblnk ; 'blink again
erpbw2 CALL keyget ; get char
CALL etstint ; test interrupt
CALL upcase ; UpCase
CMP AL,#$59 ; Y ?
JZ erpdoit ; :yes, do it
CMP AL,#$19 ; ^Y ?
JNZ erpbk
erpdoit MOV.B txchg,#$FF ; set flags: text changed
MOV.B txcomp,#$00 ; code invalid
MOV.B CL,srrepl1 ; length of replacement
MOV CH,#$00
POP BX ; restore pos
PUSH BX
PUSH CX ; save
MOV AL,srword1 ; length of word found
SUB.B AL,CL ; - length of replacement
MOV.B CL,AL ; -> CL
LAHF ; save flags
PUSH AX
JNB erp2 ; do sign extension
DEC.B CH
erp2 TEST.B sropt,#$10 ; backwards ?
JNZ erpbw ; :yes
MOV BX,srpos ; beg of that word
erpbw POP AX ; flag
SAHF
PUSH BX
JZ erpsame ; : no difference
CALL echgsize ; change len
erpsame POP DX ; restore
POP CX
MOV.B AL,CH ; length = 0 ?
OR.B AL,CL
JZ erpnil
MOV BX,#srrepl2 ; move in replacement word
CALL movebk
erpnil CALL ekbdstat ; get KBD stat
JZ erpok ; :nothing
CALL eredall ; redisplay all
JMP.b erpchg ; '
erpok PUSH DX ; save pos
CALL erstlin ; restore line
CALL eredall ; flag: redisplay
POP DX ; restore pos
erpchg TEST.B sropt,#$10 ; backwards ?
JNZ erpbk ; :yes
POP BX ; remove
XCHG DX,BX ; set to end of word
RET ; '
erpbk POP BX ; restore beg of word
erpret RET ; "
ekw CMP.B bkhide,#$FF ; ^KW:Write block to disk
JZ erpret ; block hidden: ret
CALL eflush ; rewrite line
CALL erstlin ; restore line
MOV AX,bkbeg ; block begin > block end ?
CMP AX,bkend
JNB erpret ; yes: ret
CALL etstblk ; test block
CALL erstlin ; restore line
ekwlp CALL eclrstat ; clr status line
CALL ewrits ; write string
B "Write block to file",$00
CALL ekwfile ; get filename
JZ erpret ; nothing entered: ret
CALL kpasext ; default extension .PAS
MOV AX,#$3D00 ; open file
MOV DX,#scrpn ; name ptr
PUSH DS ; DS -> ES
POP ES
CALL dos
MOV BX,AX ; file handle
JB ekwnew
MOV AH,#$3E ; close file
CALL dos
CALL eclrs2 ; clr status line
CALL ewrits
B "Overwrite old ",$00
MOV SI,#scrpn ; write filename
CALL printpn
CALL yorn ; Y or N ?
JZ ekwlp ; no: get new filename
ekwnew MOV AH,#$3C ; create file
MOV DX,#scrpn ; name ptr
XOR CX,CX ; no attribute
PUSH DS ; DS -> ES
POP ES
CALL dos
JNB ekwopen ; :ok
CALL eclrs2 ; clr status line
CALL ewriterr ; write message
B "Unable to create ",$00
MOV SI,#scrpn ; write filename
CALL printpn
CALL waitesc ; wait for ESC
JMP ekwlp ; 'get new filename
ekwopen PUSH AX ; save file handle
CALL eclrs2 ; clr status line
POP BX ; restore
MOV DX,bkbeg ; block begin
MOV SI,bkend ; block end
MOV.B AL,[SI] ; get char at block end
PUSH AX ; save it
PUSH SI ; save its addr
MOV.B [SI],#$1A ; store a ^Z there
MOV CX,SI ; count = block end - block beg
SUB CX,DX
CMP BX,#$04 ; write to device ?
JBE ekwdev ; :yes
INC CX ; file: write ^Z, too
ekwdev MOV AH,#$40 ; write byte block
CALL dos
JB ekwfull ; :error
SUB CX,AX ; length = expected ?
JZ ekwdone ; :yes
DEC CX ; 1 byte difference ?
JNZ ekwfull ; no: error
ekwdone CALL ekwclose ; close file
JNB ekwok ; :ok
CALL ewriterr ; write message
B "Error closing file",$00
CALL waitesc ; wait for ESC
ekwok POP SI ; restore char at block end
POP AX
MOV.B [SI],AL
RET ; '
ekwfull CALL ekwclose ; close file
MOV AH,#$41 ; delete it
MOV DX,#scrpn ; name ptr
CALL dos
CALL ewriterr ; write message
B "Disk full",$00
CALL waitesc ; wait for ESC
JMP ekwok ; 'restore block end
ekwcloseMOV AH,#$3E ; close file
JMP dos ; "
ekwfile MOV DX,#fnbuf ; get filename
CALL edreadst ; read it
MOV BX,#fnbuf2 ; first char
CMP.B [BX],#$1A ; = ^Z ?
ekrret RET ; "yes: nothing entered
ekr CALL eclrstat ; ^KR:Read block from disk
CALL ewrits ; write string
B "Read block from file",$00
CALL ekwfile ; get file name
JZ ekrret ; nothing entered: ret
CALL kpasext ; default extension .PAS
MOV AX,#$3D00 ; open file
MOV DX,#scrpn ; name ptr
PUSH DS ; DS -> ES
POP ES
CALL dos ; do it
XCHG AX,BX ; file handle
JNB ekrfound ; :ok
CALL eclrs2 ; clr status line
CALL ewriterr ; write message
B "File ",$00
MOV SI,#scrpn ; write filename
CALL printpn
CALL prints ; write string
B " not found",$00
CALL waitesc ; wait for ESC
JMP ekr ; 'get another filename
ekrfoundPUSH BX ; save file handle
MOV.B bkhide,#$00 ; flag: block not hidden
CALL etstblk ; test block
MOV BX,txend ; text end
MOV DX,txmemend ; text space end
MOV CX,#$00FE ; + some space free
ADD BX,CX
SUB BX,DX
PUSH BX ; save free space
MOV CX,BX
MOV BX,nbkbeg ; new block beg
STC
CALL echgsize ; make space
POP AX ; restore free space
POP BX ; restore file handle
MOV DX,nbkbeg ; new block beg
MOV CX,DX ; -> offset
SUB CX,AX
MOV explen,CX ; save end free space
MOV vfilbig,#ebigfil ; set error vec
CALL kload2 ; load block
INC BX ; end of block read
MOV bkend,BX ; store as new block end
XCHG DX,BX ; -> DX
MOV BX,nbkbeg ; new block beg
MOV bkbeg,BX ; -> block beg
ekrremovMOV BX,explen ; end free space
SUB BX,DX ; -block end
MOV CX,BX ; -> count
JMP.b ekvremov ; 'remove unneeded space
MOV DX,nbkbeg ; File too big:
CALL ekrremov ; remove space made free
JMP etsterr ; "error: out of space
eblkmov CALL etstblk ; ^KV:Move block - test block
JNB ekvrest
CALL ecopyblk ; copy it
MOV BX,nbkbeg ; new block beg
MOV DX,bkbeg ; -> block beg
MOV bkbeg,BX
ADD BX,CX ; + count
MOV bkend,BX ; -> block end
ekvremovXCHG BX,DX ; old block beg -> BX
CLC
CALL echgsize ; remove old block
MOV BX,bkbeg ; block begin
CALL efsetpos ; set position
JMP erewrall ; 'rewrite all
ekvrest JMP erstlin ; "restore line
eblkcpy CALL etstblk ; ^KC:Copy block - test block
JNB ekvrest
CALL ecopyblk ; do copy it
MOV BX,nbkbeg ; new block beg
MOV bkbeg,BX ; -> block beg
ADD BX,CX ; + count
MOV bkend,BX ; -> block end
CALL eseldisp ; selective redisplay
CALL erstlin ; restore line
JMP erewrall ; "rewrite all
etstblk CMP.B bkhide,#$00 ; Test block
JZ etb2 ; :block not hidden
CLC
RET ; '
etb2 CALL esrcend ; search end of input line
INC BX ; +1
MOV DX,lnpos ; pos in input line
PUSH DX ; save it
CALL emin ; take smaller of them
XCHG BX,DX ; -> BX
CALL efl2 ; write back to memory
POP BX ; restore pos in input line
MOV DX,#line ; calc relative pos in input line
SUB BX,DX
MOV DX,edpos ; +pos of current line
ADD BX,DX
MOV nbkbeg,BX ; -> new block beg
PUSH BX ; save
MOV DX,bkbeg ; block beg+1
INC DX
CMP BX,DX ; destination inside block ?
MOV DX,bkend ; block end
JB etbbeg ; :no
CMP BX,DX
JNB etbbeg ; :no
OR.B AL,AL ; dest is in old block...
JMP.b etb3 ; 'end it
etbbeg MOV BX,bkbeg ; block beg
SUB BX,DX ; -block end
MOV nbk,BX ; -> - block len
MOV CX,BX ; -> count
etb3 POP BX ; restore destination
RET ; "
ecopyblkCALL echgsize ; Copy block: make space for it
MOV CX,nbk ; get count
NEG CX ; (is - block len)
MOV DX,nbkbeg ; block destination
MOV BX,bkbeg ; block source
PUSH CX ; save count
CALL movebk ; move it
POP CX ; restore count
RET ; "
eblkdel CALL eflush ; ^KY:Delete block - rewrite line
CMP.B bkhide,#$00 ; block hidden ?
JNZ ekyrest
MOV BX,bkbeg ; block beg
CALL esrcbeg ; search beg of line
MOV edpos,BX ; -> current pos
MOV BX,posfifo ; update pos FIFO
MOV DX,bkbeg ; inside block ?
INC DX
CMP BX,DX
JB ekynochg ; :no
MOV DX,bkend
CMP BX,DX
JNB ekynochg ; :no
MOV BX,edpos ; current pos
MOV posfifo,BX ; -> FIFO
ekynochgMOV BX,bkend ; block end-block beg
MOV DX,bkbeg
SUB BX,DX ; calc count
JNB ekyblkok ; :ok
ekyrest JMP erstlin ; 'restore line
ekyblkokMOV CX,BX ; -> count
XCHG BX,DX ; swap addrs
PUSH BX ; save them
PUSH CX
PUSHF
CALL eseldisp ; do selective rewrite
POPF
POP CX ; restore
POP BX
CALL echgsize ; delete block
MOV BX,edpos ; current pos
MOV bkbeg,BX ; -> block beg
MOV bkend,BX ; -> block end
CALL erstlin ; restore line
JMP.b erewrall ; "rewrite all
NOP ; ^KH:hide / unhide block
ekh NOT.B bkhide ; toggle flag: block hidden
JMP.b erewrall ; "rewrite all
NOP ; Mark block end
emarkendMOV BX,lnpos ; pos in line
MOV bkendl,BX ; -> block end in buffer
MOV BX,edpos ; line pos
MOV bkend,BX ; -> block end
TEST.B attflg,#$02 ; block marked in this line ?
LAHF
OR.B attflg,#$02 ; set that flag
emrend2 CMP.B bkhide,#$FF ; block hidden ?
MOV.B bkhide,#$00 ; make it visible
JZ erewrall ; hidden: rewrite all
SAHF
JZ erewrall ; no block marked in line: all
JMP.b erewrlin ; "rewrite line, only
NOP ; Mark block beg
emarkbegMOV BX,lnpos ; get pos in line
MOV bkbegl,BX ; -> block beg in line buffer
MOV BX,edpos ; current pos
MOV bkbeg,BX ; -> block beg
TEST.B attflg,#$01 ; block beg in this line ?
LAHF
OR.B attflg,#$01 ; set flag
JMP emrend2 ; "as above
ejbkbeg CALL eflush ; ^QB:to beginning of block
MOV BX,bkbeg ; block beg
JMP efsetpos ; "set new position
ejbkend CALL eflush ; ^QK:to end of block
MOV BX,bkend ; block end
JMP efsetpos ; "set new position
erewrlinMOV BH,#$00 ; Rewrite line
CALL eposrow ; pos cursor to beg of line
MOV BX,#line ; pos of current line
MOV.B attchg,#$FF ; critical line
CALL edmalin ; display it
MOV.B attchg,#$00 ; normal again
RET ; "
erewrallCALL erewrlin ; rewrite line
JMP eredall ; "then rewrite all
ejtxend CALL eflush ; ^QC:to end of text
MOV BX,txend ; text end
JMP efsetpos ; "set new position
ejlnbeg MOV BX,#line ; ^QS:to beg of line
MOV lnpos,BX ; buffer beg -> pos in line
JMP erepos ; "reposition in line
ejlnend CALL esrcend ; ^QD:to end of line
INC BX ; search end of line+1
MOV DX,#lineend ; too much ?
CMP BX,DX
JB ele2 ; :no
MOV BX,#lineend1 ; limit it
ele2 MOV lnpos,BX ; set new pos in line
JMP erepos ; "reposition in line
etogovr MOV.B statobs,#$00 ; ^V:insert mode on/off
NOT.B overflg ; toggle flag
RET ; "status line obsolete
etogind MOV.B statobs,#$00 ; ^QI:indent mode on/off
NOT.B indntflg ; toggle flag
ednrt RET ; "status line obsolete
eposcur MOV.B BH,phcol ; put cursor to current pos
eposrow MOV.B BL,phrow
JMP esetcur ; "set cursor pos
edn MOV BX,edpos ; ^X:line down
CALL elindn ; go down one line
JB ednrt
CALL eflush ; rewrite line
MOV BX,edpos ; now really go down
CALL elindn
edn2 MOV edpos,BX ; store new pos
MOV.B scrfl2,#$00 ; flag: short update
MOV.B scrfl1,#$FF
CALL eseldisp ; do selective redisplay
MOV.B scrfl1,#$00 ; clear flag
JMP erstlin ; "restore line
eup MOV BX,edpos ; ^E:line up
CALL elinup ; go up one line
JB ednrt
PUSH BX ; save pos
CALL eflush ; rewrite line
POP BX ; now go there
JMP edn2 ; "set it
escrup MOV AX,disbeg ; ^W:scroll up
CMP AX,txbeg ; display beg = text beg ?
JZ eptret ; yes: ret
CALL eflush ; rewrite line
XOR CX,CX ; count pos on screen
MOV BX,edpos ; current pos
esulp CMP BX,disbeg ; = display beg ?
JZ esu2 ; yes: do it
CALL elinup ; go up one line
INC CX ; count it
JMP esulp ; '
esu2 XCHG BX,edpos ; current pos = top of screen
CS:
MOV AL,txwiny2 ; line count - 3
SUB AL,#$03
CMP.B CL,AL ; = count ?
JNZ esu3 ; no: ok
CALL elinup ; go up one line
esu3 PUSH BX ; save current pos
MOV BX,edpos ; display beg
CALL elinup ; go up one line
CALL edn2 ; display it
POP BX ; restore current pos
esu4 JMP edn2 ; "set new pos
escrdn CALL eflush ; ^Z:scroll down
PUSH edpos ; save current pos
MOV BX,disbeg ; start from display beg
XOR CX,CX
CS:
MOV.B CL,txwiny2 ; line count-2 -> CX
SUB.B CL,#$02
esdlp CALL elindn ; go down one line
LOOP esdlp ; do it again
PUSHF
CALL edn2 ; set new pos
POPF
POP BX ; restore old pos
JB esu4 ; :set new pos
CMP BX,disbeg ; >= display beg ?
JNB esu4 ; :set new pos
CALL elindn ; go down one line
JMP esu4 ; 'set new pos
eptret RET ; "
epagtop MOV BX,disbeg ; ^QE:to page top
CMP BX,edpos ; display beg = current line ?
JZ eptret ; yes: done
PUSH BX ; save this pos
CALL eflush ; rewrite line
POP BX ; display beg -> new pos
JMP esu4 ; "set that pos
epagbot CALL eflush ; ^QX:to bottom of page
MOV BX,disbeg ; display beg
XOR CX,CX ; line count-3 -> CX
CS:
MOV.B CL,txwiny2
SUB.B CL,#$03
epblp CALL elindn ; go down one line
LOOP epblp ; :again
JMP esu4 ; "set new pos
epagdn CALL eflush ; ^C:page down - rewrite line
CS:
MOV AL,txwiny2 ; line count - 2
SUB AL,#$02
MOV.B CH,AL ; -> CL, CH
MOV.B CL,AL
MOV BX,disbeg ; display beg
epdlp CALL elindn ; go down one line
DEC.B CH
JNZ epdlp ; :another one
MOV disbeg,BX ; store new display beg
MOV BX,edpos ; current pos
epdl2 CALL elindn ; go down one line
LOOP epdl2 ; :again
epd2 MOV edpos,BX ; set new pos
CALL eseldisp ; redisplay
CALL eredall ; redisplay all
JMP erstlin ; "restore line
epagup CALL eflush ; ^R:page up - rewrite line
CS:
MOV AL,txwiny2 ; line count - 2
SUB AL,#$02
MOV.B CH,AL ; -> CL, CH
MOV.B CL,AL
MOV BX,disbeg ; display beg
epulp CALL elinup ; go up one line
DEC.B CH
JNZ epulp ; :another
MOV disbeg,BX ; store new display beg
MOV BX,edpos ; current pos
epul2 CALL elinup ; go up one line
LOOP epul2 ; :another
JMP epd2 ; "set new pos, redisplay
etxtbeg MOV BX,disbeg ; ^QR:to beg of text
MOV DX,txbeg ; text beg = display beg ?
CMP BX,DX
JZ etsb2 ; :yes
CALL eredall ; no:redisplay all
etsb2 CALL eflush ; rewrite line
MOV BX,txbeg ; text beg
MOV edpos,BX ; -> current pos
MOV disbeg,BX ; -> display beg
CALL eseldisp ; do selective redisplay
CALL erstlin ; restore line
MOV BX,#line ; go to beg of line
MOV lnpos,BX ; pos in line
JMP erepos ; "reposition in line
ecr CMP.B overflg,#$00 ; CR:carriage return
JNZ ecrins ; :insert mode
CALL edn ; go down one line
JMP ejlnbeg ; 'go to beg of line
ecrins MOV.B txchg,#$FF ; set flags: text changed
MOV.B txcomp,#$00
MOV BX,phrow ; current cursor pos
INC.B BL
CALL esetcur ; set cursor to beg of line
CALL elinbrk ; insert line break
MOV BX,edpos
PUSH BX ; save current pos
CALL erstlin ; restore line
CALL eflush ; rewrite line
POP BX ; restore current pos
CALL elindn ; go down one line
MOV edpos,BX ; -> current pos
MOV BX,#line ; go to beg of line
CALL eredisp ; redisplay
CALL eposcur ; set new position
CMP.B indntflg,#$00 ; indent ?
JZ elftret ; :no
CALL etabup ; up one line from curr pos
JB elftret ; :no
MOV SI,#esepspc ; separator: spaces only
CALL etslp ; 'go word right
JNB elftret
JMP etab ; "do tab
eredisp MOV lnpos,BX ; store pos in buffer
CALL erepos ; reposition in line
CALL eseldisp ; selective redisplay
JMP erstlin ; "restore line
elinins CALL elinbrk ; ^N:insert line - insert line break
MOV.B BL,phrow ; row + 1
INC.B BL
XOR.B BH,BH ; col = 0
CALL esetcur ; set cursor pos
MOV BX,edpos ; current pos
CALL elindn ; go down one line
CALL edmalin ; display line
JMP erstlin ; "restore line
elinbrk CALL eflush ; Insert line break: rewrite line
CALL xinsline ; InsLine
CALL esrcend ; search end of line + 1
INC BX
MOV DX,lnpos ; pos in buffer
CALL emin
MOV DX,#line ; relative pos in line
SUB BX,DX
elb2 XCHG BX,DX ; -> DX
MOV BX,edpos ; current pos
ADD BX,DX ; + relative pos
PUSH BX ; save pos of line break
STC ; insert two bytes
MOV CX,#$FFFE
CALL echgsize ; do it
POP BX ; restore pos
MOV [BX],#$0A0D ; store CR, LF there
INC BX
elftret RET ; "
eleft MOV BX,lnpos ; ^S, ^H:character left
DEC BX ; pos in line - 1
CMP BX,#line ; already at the beg ?
JB elftret
eleft2 MOV lnpos,BX ; set new pos
JMP erepos ; "reposition in line
eright MOV BX,lnpos ; ^D:character right
INC BX ; pos in line + 1
CMP BX,#lineend0 ; = end of buffer ?
JB eleft2 ; below: ok, set it
RET ; "
elstpos CALL eflush ; ^QP:to last position
MOV BX,qppos ; get pos from FIFO
CALL esrcbeg ; search beg of line
MOV edpos,BX ; -> current pos
MOV BX,qppos1 ; get display beg from FIFO
JMP eredisp ; "redisplay
emrkwrd CALL ewrdrt ; ^T:mark word - word right
CALL ewrdlft ; word left
MOV BX,lnpos ; pos in line buffer
emwlp CALL etstsep ; char = separator ?
JB emwend ; yes: word end found
INC BX ; next char
CMP BX,#lineend0 ; end of line ?
JB emwlp ; :no, continue
emwend MOV lnpos,BX ; -> current pos
CALL emarkend ; mark block end
CALL ewrdlft ; go left one word
JMP emarkbeg ; "mark block beg
ewlup MOV BX,edpos ; get current pos
CALL elinup ; go up one line
JB ewloldp
PUSH BX ; save pos
CALL eflush ; rewrite line
POP BX
MOV edpos,BX ; set new pos
MOV.B scrfl2,#$00 ; set flag: short updating
CALL eseldisp ; selective redisplay
CALL erstlin ; restore line
CALL esrcend ; search end of line
JMP.b ewlle ; 'store position
ewrdlft MOV BX,lnpos ; ^A:word left
ewllp DEC BX ; pos in buffer-1:search char<>sep
CMP BX,#line ; = line beg ?
JB ewlup ; yes: go up one line
CALL etstsep ; char = separator ?
JB ewllp ; yes: continue searching
ewll2 DEC BX ; go back: search separator
CMP BX,#$046C ; = line beg ?
JB ewlle ; yes: end it
CALL etstsep ; char = separator ?
JNB ewll2 ; :no
ewlle INC BX ; go to left of word
ewlpos MOV lnpos,BX ; store pos in line
ewloldp MOV BX,lnpos ; get pos
JMP erepos ; "reposition in line
ewrdrt CALL esrcend ; ^F:word right
MOV AX,BX ; end of line -> AX
MOV BX,lnpos ; pos in line
SUB AX,BX ; calc count
MOV AL,#$00
JNB ewr1 ; :ok
INC.B AL
ewr1 MOV curpast,AL ; flag: cursor past end of line
ewrlp DEC BX
ewrl2 INC BX ; next char
CMP BX,#lineend0 ; end of line ?
JB ewrtst ; :no
ewrl3 MOV BX,edpos ; current pos
CALL elindn ; go down one line
JB etabret
CALL eflush ; rewrite line
MOV BX,edpos ; current pos
CALL elindn ; go down
MOV edpos,BX ; new pos
MOV.B scrfl2,#$00 ; short update
CALL eseldisp ; redisplay
CALL erstlin ; restore line
MOV BX,#$046C ; go to beg of line
MOV lnpos,BX
CALL etstsep ; char = separator ?
JB ewrlp ; :yes
JMP erepos ; 'set that pos
ewrtst CALL etstsep ; char = separator ?
JNB ewrl2 ; :no
ewrlp2 INC BX ; next char
CMP BX,#lineend0 ; end of line ?
JB ewrtst2 ; :no
CMP.B curpast,#$00 ; cursor past end of line ?
JNZ ewrl3 ; :yes
CALL esrcend ; search end of line + 1
INC BX
JMP ewlpos ; 'set that pos
ewrtst2 CALL etstsep ; char = separator ?
JB ewrlp2 ; :yes
JMP ewlpos ; "set that pos
etabup MOV BX,edpos ; current pos
CALL elinup ; go up one line
etabret RET ; "
etab CALL etabup ; ^I:Tab - go up one line
JB etabret
MOV AL,phrow ; save phys row
PUSH AX
MOV BX,lnpos ; pos in line
MOV lnupper,BX ; store pos of upper line
MOV.B disflg,#$00 ; normal mode
CALL eflush ; rewrite line
MOV BX,edpos ; current pos
PUSH BX ; save it
CALL elinup ; go up one line
MOV edpos,BX ; store pos
CALL erstlin ; restore line
PUSH sepptr ; save ptr
MOV sepptr,#esepspc ; set sep ptr: spaces only
CALL ewrdrt ; word right
POP sepptr ; restore sep ptr
POP edpos ; restore current pos
POP AX
MOV phrow,AL ; restore phys row
CALL erstlin ; restore line
MOV.B disflg,#$FF ; flag: short update
CMP.B overflg,#$FF ; insert ?
JZ etabins ; :yes
JMP erewrlin ; 'rewrite line
etabins MOV BX,lnpos ; pos in line
MOV DX,lnupper ; pos in upper line
SBB BX,DX ; difference
JBE etabret ; not found: ret
XCHG BX,DX ; -> count
etabinslPUSH DX ; save count
CALL einsch ; insert a char
MOV.B [BX],#$20 ; space
POP DX ; restore count
DEC.B DL ; another ?
JNZ etabinsl ; :yes
JMP erewrlin ; "rewrite line
edeleol MOV BX,lnpos ; ^QY:delete to end of line
PUSH BX ; save pos in line
CALL etstbk ; test block markers in line
POP BX ; restore pos
PUSH BX
MOV DX,#lineend1 ; end position
edelp MOV.B [BX],#$20 ; fill up with spaces
CMP BX,DX ; end reached ?
JZ edeend ; :yes
INC BX ; next char
JMP edelp ; '
edeend POP BX ; restore pos in line
JMP eredlin ; "redisplay line
edellin MOV BX,#line ; ^Y:delete line
MOV lnpos,BX ; to line beg
CALL erepos ; reposition in line
CALL edeleol ; delete to end of line
CALL eflush ; rewrite line
MOV BX,edpos ; current pos
PUSH BX ; save it
PUSH BX
CALL elindn ; go down one line
POP DX ; old pos
JB edlend
SUB BX,DX ; difference
MOV CX,BX ; -> count
POP BX ; restore current pos
JNZ edb3 ; :erase the rest
RET ; '
edlend POP BX ; remove from stack
JMP erstlin ; "restore line
edlinbrkCALL efl2 ; del line break: rewrite to BX
MOV BX,edpos ; current pos
CALL elindn ; go down one line
JNB edb2 ; :ok
JMP erstlin ; 'restore line
edb2 DEC BX ; go back two bytes
DEC BX
MOV CX,#$0002 ; delete 2 bytes
OR.B AL,AL ; clear carry
edb3 CALL echgsize ; do it
CALL xdelline ; DelLine
CS:
MOV AL,txwiny2 ; get line cnt - 1
DEC.B AL
CALL edsplin ; redisplay last line
JMP erstlin ; "restore line
edelwrd CALL esrcend ; ^T:delete right word
MOV DX,lnpos ; pos in buffer
CMP BX,DX ; > end ?
XCHG BX,DX
JB edlinbrk ; :delete line break
MOV.B AL,[BX] ; get char
CMP AL,#$20 ; space ?
JZ edelspc ; :delete spaces
CALL etstsep ; separator ?
JB edel2 ; :end it
edwlp CALL edelch ; delete char
CALL etstsep ; separator ?
JB edrest ; :yes, end
JMP edwlp ; "another char
edwend MOV BX,edpos ; current pos
CALL elinup ; up one line
JB edwret
CALL eup ; line up
CALL ejlnend ; go to line end
JMP edelwrd ; 'delete word
edwret RET ; '
edelrt MOV BX,lnpos ; ^G:delete right
JMP.b edel2 ; '
edellft MOV BX,lnpos ; DEL:delete left
DEC BX ; go back one char
CMP BX,#line ; beg of line ?
JB edwend ; yes: go to line above
MOV lnpos,BX ; store new pos
edel2 CALL edelch ; delete char
edrest CALL erepos ; reposition on line
JMP eredlin ; "redisplay line
edelspc CALL edelch ; Delete spaces
MOV.B AL,[BX] ; get char
CMP AL,#$20 ; space ?
JZ edelspc ; :delete it
JMP edrest ; "redisplay
eredisplCALL eposcur ; Redisplay: set cursor pos
CALL edisbdn ; go down from display beg
edisp1 CALL ekbdstat ; get KBD stat
JNZ edisp2
CALL edsp2 ; redisplay
JNB edisp1 ; :continue
edisp2 JMP eposcur ; "set cursor pos
edodisplCALL eposcur ; Redisplay: set cursor pos
CALL edisbdn ; go down from display beg
eddlp CALL edsp2 ; redisplay
JNB eddlp ; :continue
JMP eposcur ; "set cursor pos
edisbdn MOV.B CL,dislin ; go down from display beg
edisbdn2XOR.B CH,CH ; count: first line to display
MOV BX,disbeg ; display beg
DEC CX ; count down
JZ eddnil ; :end it
eddn CALL elindn ; go down one line
JB eddend
LOOP eddn ; :another line
eddnil RET ; '
eddend MOV BX,txend ; go to text end
RET ; "
edodisp CALL elindn ; do redisplay: go down
JNB edsp2 ; :ok
MOV BX,txend ; go to text beg
edsp2 MOV AL,dislin ; display from where ?
CS:
CMP.B AL,txwiny2 ; = line cnt ?
JNB edspret
INC.B dislin ; go down one more line
CMP.B AL,phrow ; = phys row ?
JZ edodisp ; yes: go down
edsp3 MOV scrrow,AL ; current line
CMP BX,txend ; text end reached ?
JNB edsp4 ; :yes
CALL edmalin ; display line
CLC ; not yet end
RET ; '
edsp4 CALL esetnrm ; NormVideo
CALL eclrlin ; clear line
CLC ; not yet end
RET ; '
edspret STC ; end it
RET ; "
edsplin PUSH AX ; redisplay one line
MOV.B CL,AL ; line number
CALL edisbdn2 ; go down to this line
POP AX ; restore
JMP edsp3 ; "redisplay that line
esrcbeg MOV AL,#$0A ; search beg of line: LF
esblp DEC BX ; go back
CMP BX,txbeg ; text beg ?
JZ esbend ; yes: end it
JB esb1 ; below: next char
CMP.B AL,[BX] ; test char: LF ?
JNZ esblp ; no: continue searching
esb1 INC BX ; next char
esbend RET ; "
eskipcr CMP AL,#$0D ; Skip CR
JNZ escret ; no: ret
MOV.B AL,[BX] ; get char
INC BX ; next char
CMP BX,txend ; text end ?
JB eskipcr ; no: continue
escret RET ; "
eclrlin CS: ; Clear line
MOV.B CH,txwinx2 ; col count-1
DEC.B CH
JMP eclrln ; "clear line
escrdma PUSH DS ; Prepare screen DMA
POP ES ; DS -> ES
MOV DI,#dmabuf ; ptr to DMA buffer
CLD
XOR.B AH,AH ; AL -> CX = pos in line
MOV CX,AX
MOV SI,AX ; AL*2 -> SI
ADD SI,SI
CS:
MOV AL,txwinx2 ; column count * 2
ADD AX,AX
MOV BP,AX ; -> BP
SUB BP,SI ; - horizontal offset
MUL.B scrrow ; line length * current row
ADD BP,AX ; + row position
RET ; "
escrdma2INC.B AL ; column + 1
CALL escrdma ; prepare DMA
DEC CX ; char cnt-1
JMP.b edlcrit ; "do it
edmalin CS: ; Display line
MOV AL,txwinx2 ; column count
CALL escrdma ; prepare screen DMA
DEC CX ; count down
MOV.B AH,horscr ; horizontal scroll
OR.B AH,AH ; =0 ?
JZ edlcrit
edl1 CALL esetatt ; set attribute
MOV.B AL,[BX] ; get char
INC BX ; next char
CMP BX,txend ; text end ?
JNB edletx ; :yes
CALL eskipcr ; skip CR
CMP AL,#$0A ; LF ?
JZ edletx ; :yes
DEC.B AH ; another char ?
JNZ edl1 ; :yes
edlcrit CMP.B attchg,#$00 ; critical line
JZ edlatt ; :no
PUSH BX ; save pos
CALL esrcend ; search end of line
MOV AX,lnpos ; pos in line = end of line ?
CMP AX,BX
JBE edllim ; :ok
MOV BX,AX ; limit it
edllim INC BX
MOV eolpos,BX ; pos: end of line
POP BX ; restore pos
CALL esetatt ; set attribute
CMP BX,eolpos ; = pos EOL ?
JNB edletx ; :yes
edlatt CALL esetatt ; set attribute
CMP BX,eolpos ; end of line ?
JZ edletx ; yes: end
MOV.B AL,[BX] ; get char
INC BX ; next
CMP BX,txend ; text end ?
JA edletx ; yes: end
CMP AL,#$0D ; CR ?
JZ edllp ; yes: forget it
CMP AL,#$20 ; control char ?
JNB edlnrm ; :no, normal
ADD AL,#$40 ; convert to normal
PUSH AX ; save it
CALL etogatt ; set attribute
POP AX ; restore
edlnrm MOV.B AH,attcur ; current attribute
STOS ; store in buffer
LOOP edlatt ; :another char
edllp MOV.B AL,[BX] ; get char
INC BX
CMP BX,txend ; text end ?
JA edletx ; :yes
CMP AL,#$0A ; LF ?
JNZ edllp ; :not yet
edletx INC CX ; one more byte
MOV AL,#$20 ; fill up with spaces
MOV.B AH,attcur ; current attribute
REPZ
STOS
CMP.B disflg,#$00 ; display it ?
JZ edlret ; :no
MOV CX,SI ; byte number / 2 -> words
SHR CX,1
MOV DI,BP ; destination ofs
MOV ES,scrseg ; screen segment
MOV SI,#dmabuf ; buffer addr
CMP.B scrbad,#$FF
JZ edlbad ; :yes
REPZ ; just move it into screen memory
MOVS
edlret RET ; '
edlbad MOV DX,#$03DA ; test port
edlblp LODS ; get word
MOV BP,AX ; save it
edlbw1 IN AL,DX ; get status
RCR.B AL,1
JB edlbw1 ; :wait
CLI ; no INT allowed
edlbw2 IN AL,DX ; get status
RCR.B AL,1
JNB edlbw2 ; :wait
XCHG AX,BP ; restore char
STOS ; store it
STI ; clear interrupt
LOOP edlblp ; :another char
edlbret RET ; "
esetatt CMP.B bkhide,#$FF ; Set attribute
JZ esetnrm ; :block hidden
CMP.B attchg,#$FF ; block beg/end in this line ?
JZ esetblk ; :no
CMP BX,bkbeg ; block begin ?
JB esetnrm ; :no, normal
CMP BX,bkend ; block end ?
JNB esetnrm ; above: normal
JMP.b eset2 ; 'in block !
esetblk CMP BX,bkbegl ; = pos block beg in buffer ?
JB esetnrm ; :no, normal
CMP BX,bkendl ; > pos block end in buffer ?
JNB esetnrm ; yes: normal
eset2 CMP.B disflg,#$00 ; display it ?
JZ edlbret ; :no
JMP vidattr2 ; 'Attribute #2
esetnrm CMP.B disflg,#$00 ; display it ?
JZ edlbret ; :no
JMP knrmvid ; "NormVideo
esetlow CMP.B disflg,#$00 ; display it ?
JZ edlbret ; :no
JMP klowvid ; "LowVideo
etogatt CMP.B curatt,#$01 ; low set ?
JZ esetnrm ; yes:NormVideo
JMP esetlow ; "LowVideo
eclrln CMP.B disflg,#$00 ; Clear line
JZ edlbret
PUSH AX ; save
PUSH DX
MOV.B AL,CH ; line number+1
INC.B AL
CALL escrdma ; prepare screen DMA
DEC CX ; length-1
CALL edletx ; erase to end of line
POP DX ; restore
POP AX
RET ; "
escrolupMOV BX,#$0001 ; Scroll up
CALL esetcur ; set cursor pos: top line
JMP xdelline ; "DelLine
erstlin MOV BX,edpos ; ^QL:restore line
MOV DX,#$0000 ; clear block pos in buf:
MOV bkbegl,DX ; block beg
MOV bkendl,DX ; block end
MOV CH,#$7F ; up to 127 chars
MOV SI,#line ; dest: line buffer
MOV.B attflg,#$00 ; flag: no block beg / end
erllp MOV.B AL,[BX] ; get char
CMP BX,bkbeg ; block beg ?
JNZ erlnbeg ; :no
MOV bkbegl,SI ; pos block beg in line
OR.B attflg,#$01 ; block beg in this line
erlnbeg CMP BX,bkend ; block end ?
JNZ erlnend ; :no
MOV bkendl,SI ; pos block end in line
OR.B attflg,#$02 ; block end in this line
erlnend CMP AL,#$0D ; CR ?
JNZ erlnext ; no:next char
MOV.B [SI],#$20 ; store a space
INC SI ; next
DEC.B CH ; count down
JZ elonglin ; :line too long
INC BX ; next char
CMP BX,txend ; end of text ?
JNB erllp ; :no, continue
erlend CMP BX,bkend ; block active in this line ?
JNB erlbeg ; :no
PUSH BX ; save pos
MOV BX,#$FFFF ; flag: block ends after
MOV bkendl,BX ; this line
POP BX
erlbeg CMP BX,bkbeg ; block beg ?
JNB erllen
MOV BX,#$FFFF ; flag: block starts before this
MOV bkbegl,BX ; line
erllen MOV AL,#$7F ; test line length
SUB.B AL,CH
MOV oldlen,AL ; store old length
erlpad MOV.B [SI],#$20 ; fill up with spaces
INC SI
DEC.B CH
JNZ erlpad ; :again
MOV BX,lnpos ; pos in buffer
CALL erepos ; reposition in line
CMP.B scrfl2,#$00 ; small move only ?
MOV.B scrfl2,#$FF ; reset flag
JZ erldisp ; :yes
JMP erewrlin ; 'redisplay line
erldisp MOV AL,dislin ; redisplay from ...
DEC.B AL
CMP.B AL,phrow ; = phys row ?
JNB eseret ; above: ret
JMP erewrlin ; 'rewrite line
erlnext CMP AL,#$0A ; LF ?
JZ erlend ; yes: end it
MOV.B [SI],AL ; store char
INC SI ; go to next
DEC.B CH ; too much ?
JNZ erletx ; :no
JMP.b elonglin ; 'error: long line
erletx INC BX ; end of text ?
CMP BX,txend
JNB erlend ; yes: end it
JMP erllp ; "continue
elonglinCALL eclrstat ; Insert line break - line too long
CALL ewriterr ; write message
B "Line too long - CR inserted",$00
CALL waitesc ; wait for ESC
MOV BX,#$007D ; offset
CALL elb2 ; insert line break
CALL erstlin ; restore line
JMP erewrall ; "rewrite all
eclrstatCALL edodispl ; Clear status line
eclrs2 MOV.B statobs,#$00 ; status line destroyes
MOV BX,#$0000 ; set cursor pos
CALL esetcur
CALL knrmvid ; NormVideo
CALL eclrlin ; clear line
MOV BX,#$0000 ; set cursor pos
CALL esetcur
JMP klowvid ; "LowVideo
esrcend MOV AL,#$20 ; Search end of input line
MOV BX,#lineend1 ; end pos
MOV DX,#line0 ; start pos
eselp CMP.B AL,[BX] ; space ?
JNZ eseret ; no: end found
DEC BX ; search backwards
CMP BX,DX ; beg reached ?
JNZ eselp ; no:continue
eseret RET ; "
elimpos MOV DX,#lineend ; BX>end of line ?
CMP BX,DX
JNB eseret ; :ret
MOV DX,CX
JMP emin ; "min(BX,DX)->BX
eflush CALL esrcend
INC BX ; search end of line + 1
efl2 MOV CX,BX ; end position
MOV BX,bkbegl ; pos block beg in buf
CALL elimpos ; limit to end position
MOV bkbegl,BX
MOV BX,bkendl ; pos block beg in buf
CALL elimpos ; limit to end position
MOV bkendl,BX
MOV BX,CX ; restore end position
INC BX ; +1
MOV DX,#line ; - beg position
SUB BX,DX
PUSH BX ; -> length
MOV AL,oldlen ; old length - new length
SUB.B AL,BL
MOV.B CL,AL ; -> count
MOV CH,#$00
JNB eflpos ; :ok
MOV CH,#$FF ; negative
eflpos MOV BX,edpos ; current pos
JZ eflsame ; :no size change
CALL echgsize ; expand / shrink text
eflsame POP CX ; restore length
MOV SI,edpos ; destination pos
MOV BX,#line ; buffer pos
MOV.B CH,CL ; count
OR.B CH,CH ; test it
JZ eflend ; 0:nothing to do
efllp MOV.B AL,[BX] ; get char
CMP BX,bkbegl ; = block beg ?
JNZ eflnbeg ; :no
MOV bkbeg,SI ; set block beg
eflnbeg CMP BX,bkendl ; = block end ?
JNZ eflnend ; :no
MOV bkend,SI ; set block end
eflnend MOV.B [SI],AL ; store char
INC BX ; next char
INC SI
DEC.B CH ; another ?
JNZ efllp ; :yes
DEC SI ; go back one char
eflend MOV.B [SI],#$0D ; store CR at end
RET ; "
etstmem MOV BX,txmemend ; Test if memory full
SUB BX,DX ; end text space - new text end
JB etsterr ; :error
MOV CX,#$00FE ; 254 bytes left ?
SUB BX,CX
JNB etstret ; or more: ret
ADD BX,CX ; restore
PUSH BX
CALL eclrs2 ; clear status line
POP BX ; number free bytes
MOV CH,#$00
CALL ewriterr ; write message
B "WARNING: ",$00
CALL edcvt ; display number
CALL ewriterr ; write message
B " byte(s) left",$00
CALL waitesc ; wait for ESC
etstret RET ; '
etsterr CALL eclrstat ; clear status line
CALL ewriterr ; write message
B "ERROR: Out of space",$00
CALL waitesc ; wait for ESC
JMP edmain ; "return to main loop
etstint CMP AL,#$15 ; Test for interrupt
JNZ etstret ; :not ^U - ret
CALL eclrstat ; clear status line
CALL ewriterr ; write message
B "*** INTERRUPTED",$00
CALL waitesc ; wait for ESC
JMP edmain ; "go to main loop
echgsizePUSH BX ; Shrink or expand text
PUSH CX ; save pos,cnt
JB edinsert ; :insert, negative count
JMP edshrink ; 'delete, positive count
edinsertMOV DX,txend ; save text end
PUSH DX
PUSH DX
XCHG DX,BX ; text end - pos
SUB BX,DX
MOV BP,BX ; -> BP
POP BX ; text end
PUSH BP ; save (text end - pos)
SUB BX,CX ; text end - count
JNB etsterr ; :error - out of space
MOV DX,BX ; -> BX
PUSH DX ; save new text end
CALL etstmem ; test space free
POP DX ; restore new text end
POP CX ; restore count+1
INC CX
POP BX ; text end
MOV txend,DX ; set new text end
OR CX,CX ; test count
JZ edins2 ; 0:no move to do
CALL movebkb ; move block backwards
edins2 POP CX ; restore difference
POP BX ; pos
XCHG BX,DX
MOV BX,bkbeg ; update pointers:
CALL edupdate ; block beg
MOV bkbeg,BX
MOV BX,bkend
CALL edupdate ; block end
MOV bkend,BX
MOV BX,disbeg
CALL edupdate ; display beg
MOV disbeg,BX
MOV BX,edpos
CALL edupdate ; pos current line
MOV edpos,BX
MOV BX,posfifo
CALL edupdate ; position FIFO
MOV posfifo,BX
MOV BX,qppos
CALL edupdate ; pos FIFO 2
MOV qppos,BX
MOV BX,srend
CALL edupdate ; search limit end
MOV srend,BX
MOV BX,srbeg
CALL edupdate ; search limit beg
MOV srbeg,BX
RET ; "
edupdateCMP BX,DX ; update pointer: >pos of change ?
JBE edupret ; below/equal: no change
SUB BX,CX ; change it
edupret RET ; "
edshrinkPUSH BX ; Shrink text: save pos
ADD BX,CX ; + count
PUSH BX ; save
MOV DX,txend ; text end+1
INC DX
XCHG DX,BX ; -pos-count
SUB BX,DX
MOV CX,BX ; -> move count
POP BX ; restore source
POP DX ; restore dest
OR CX,CX ; test counter
JZ edshnil ; :nothing to move
CALL movebk ; move it - delete
DEC DX ; end pos-1
edshnil MOV txend,DX ; set new end pos
JMP edins2 ; "update pointers
etstbk PUSH BX ; Test block markers in line buffer
MOV DX,bkbegl ; pos block beg in buffer
CALL emin ; min(BX,DX)->BX
TEST.B attflg,#$01 ; block beg in this line ?
JZ etbnbeg ; :no
MOV bkbegl,BX ; set it
etbnbeg POP BX ; restore
TEST.B attflg,#$02 ; block end in this line ?
JZ etbnend ; :no
MOV DX,bkendl ; update it
CALL emin
MOV bkendl,BX
etbnend RET ; "
erepos MOV DX,#line ; Reposition in current line
CS: ; ptr line beg
MOV AL,txwinx2 ; column count - 1 -> CL
DEC.B AL
MOV.B CL,AL
SUB BX,DX ; relative pos -> BX
MOV.B AL,BL
SUB.B AL,horscr ; pos < hor scroll ?
JB erephscr ; yes: underflow
CMP.B AL,CL ; outside displayed window ?
JB erepcol ; no: ok
SUB.B AL,CL ; calc diff+1 (overflow)
INC.B AL
ADD.B AL,horscr ; add to horizontal scroll
MOV horscr,AL
CS:
MOV AL,txwinx2 ; col cnt-2 -> phys col
DEC.B AL
DEC.B AL
MOV phcol,AL
JMP erewrall ; 'redisplay all
erepcol MOV phcol,AL ; store phys col
erepret RET ; '
erephscrADD.B AL,horscr ; add to horizontal scroll
MOV horscr,AL
MOV.B phcol,#$00 ; phys col 0
JMP erewrall ; "rewrite all
eseldispCMP.B disflg,#$00 ; Do selective rewrite
JZ erepret
MOV BX,disbeg ; display beg
MOV AX,txbeg ; text beg
CMP AX,BX ; the same ?
JBE esd2 ; :yes
MOV disbeg,AX ; store to display beg
MOV BX,AX
esd2 MOV CX,#$0001 ; line cnt
MOV DX,edpos ; current pos
CMP BX,DX ; = display beg ?
JNZ esd3 ; :no
JMP esd9 ; 'yes: done
esd3 JB esddn ; below: search down
esd4 MOV DX,edpos ; current pos
CMP BX,DX ; = ?
JZ esd5
CALL elinup ; go up one line
INC CX ; count it
JMP esd4 ; '
esd5 MOV disbeg,BX ; store display beg
MOV.B phrow,#$01 ; phys row
MOV.B scrfl2,#$FF ; set flag
XOR AX,AX
CS:
MOV AL,txwiny2 ; row cnt - 1
SUB AX,#$0001
CMP AX,CX ; = line ?
JB esdredsp ; below: ok
DEC CX ; go back one line
MOV BX,#$0001 ; set cursor pos:
CALL esetcur ; below status line
DEC CX ; test it
PUSHF
INC CX ; restore
esdinsl CALL xinsline ; InsLine
LOOP esdinsl ; :again
POPF ; one only ?
JNZ esdredsp ; no: do redisplay
RET ; '
esdredspJMP eredall ; 'redisplay all
esddn CMP BX,edpos ; >= current pos
JNB esd6 ; :not yet
CALL elindn ; go down one line
INC CX ; count
JMP esddn ; '
esd6 OR.B CH,CH ; clear count
JNZ esd10 ; :much
CS:
MOV AL,txwiny2 ; line count-1 -> DL
DEC.B AL
MOV.B DL,AL
MOV.B AL,CL ; counter-line cnt+1 -> DH
SUB.B AL,DL
MOV.B DH,AL
INC.B DH
JB esd9 ; :ok
DEC.B DH ; test it
JNZ esd7
CMP.B scrfl1,#$FF ; test flag
JNZ esd7 ; :normal
JMP.b esd11 ; 'keep it short
NOP
esd7 INC.B DH
SUB.B AL,DL
JNB esd10
MOV AL,dislin ; redisplay from
SUB.B AL,DH
JBE esd10
MOV dislin,AL ; set it
MOV BX,disbeg ; display beg
MOV.B CH,DH
PUSH DX
esdscrl CALL elindn ; go down one line
PUSH BX ; save pos
CALL escrolup ; scroll up
POP BX ; restore
DEC.B CH ; count down
JNZ esdscrl ; :another
MOV disbeg,BX ; store display beg
POP DX
esd8 DEC.B DL
MOV.B phrow,DL ; phys row
RET ; '
esd9 MOV.B phrow,CL
RET ; '
esd10 MOV BX,disbeg
DEC CX
CS: ; line cnt - 3 -> DL
MOV AL,txwiny2
SUB AL,#$03
MOV.B DL,AL
MOV.B AL,CL
SUB.B AL,DL
MOV.B CL,AL
JNB esddn2
DEC.B CH
esddn2 CALL elindn ; go down one line
LOOP esddn2 ; :again
MOV disbeg,BX ; store display beg
CALL eredall ; redisplay all
MOV.B scrfl2,#$FF ; set flag: long update
JMP eseldisp ; 'do it again
esd11 CALL esd8 ; set phys row
MOV AL,dislin ; redisplay from
CS:
CMP.B AL,txwiny2 ; = line cnt ?
JZ esd12 ; :yes
DEC.B AL
JZ esd12
MOV dislin,AL ; set: redisplay from
esd12 MOV BX,disbeg ; display beg
CALL elindn ; go down one line
MOV disbeg,BX ; -> new display beg
CALL escrolup ; scroll up
CS:
MOV AL,txwiny2 ; line cnt - 1
DEC.B AL
JMP edsplin ; "redisplay one line
etstsep MOV SI,sepptr ; Char = separator ?
etslp CS: ; get ptr to table
MOV.B AL,[SI] ; get char from table
OR.B AL,AL ; table end ?
JZ etsno ; :yes
CMP.B AL,[BX] ; = text char ?
JZ etsyes ; :yes
INC SI ; try next char
JMP etslp ; '
etsyes STC ; found it !
etsno MOV DX,SI ; DX=pos in table
RET ; "
LAHF ; redisplay current line
PUSH AX ; save
MOV AL,phrow ; phys row
CMP.B AL,dislin ; >= redisplay from ?
JNB erc2 ; :ok
MOV dislin,AL ; redisplay current line, too !
erc2 POP AX ; restore
SAHF
RET ; "
eredall MOV.B dislin,#$01 ; set flag: redisplay all
RET ; "
eblkupdtXCHG BX,DX ; Update blocks
TEST.B attflg,#$01 ; block beg in this line ?
JZ ebunobk ; :no
MOV BX,bkbegl ; pos block in buffer
CMP BX,DX ; < BX ?
JB ebunobk ; :ok
ADD BX,CX ; add count
MOV bkbegl,BX ; -> update
ebunobk TEST.B attflg,#$02 ; block end in this line ?
JZ ebunochg ; :no
MOV BX,bkendl ; pos block end in buffer
CMP BX,DX ; < BX ?
JB ebunochg ; :ok
ADD BX,CX ; add count
MOV bkendl,BX ; -> update
ebunochgXCHG BX,DX ; restore BX
RET ; "
edelch PUSH BX ; delete char: save pos
MOV CX,#$FFFF ; 1 char back
CALL eblkupdt ; update blocks
XCHG BX,DX ; pos -> DX
MOV BX,#lineend1 ; buffer end
SUB BX,DX ; calculate count
JZ edelcnil ; :nothing to move
MOV CX,BX ; count -> CX
MOV BX,DX ; pos -> BX
INC BX ; source: +1
CALL movebk ; move it
edelcnilMOV BX,#lineend1 ; store a space at the end
MOV.B [BX],#$20
POP BX ; restore pos
RET ; "
emin CMP BX,DX ; min(BX,DX) -> BX
JB emin2 ; max(BX,DX) -> DX
XCHG BX,DX
emin2 RET ; "
eredlin CALL eposcur ; redisplay line: set cursor pos
CS:
MOV AL,txwinx2 ; col cnt - 1
DEC.B AL
SUB.B AL,phcol ; - phys col
MOV BX,lnpos ; pos in line buffer
MOV.B attchg,#$FF ; attribute change in this line
CALL escrdma2 ; redisplay this line
MOV.B attchg,#$00 ; clear attribute flag
RET ; "
elindn MOV BP,CX ; go down one line
MOV CX,txend ; text end
MOV DI,BX ; current pos
SUB CX,DI ; text end-pos -> count
JBE eld2 ; :too much
MOV AX,DS ; DS -> ES
MOV ES,AX
CLD ; search LF
MOV AL,#$0A
REPNZ
SCAS.B
JNZ eld2 ; :not found
MOV CX,BP ; restore CX
MOV BX,DI ; pos of line break
RET ; '
eld2 MOV CX,BP ; restore CX
STC ; flag: not done
RET ; "
elinup MOV BP,BX ; go up one line
MOV AL,#$0A ; search LF
MOV DI,txbeg ; text beg = limit
DEC BX ; go back one char
elulp DEC BX ; go back
CMP BX,DI ; = end ?
JBE eluend ; :yes
CMP.B [BX],AL ; LF ?
JNZ elulp ; :no, try again
INC BX ; go to beg of line
eluend JB eluerr ; :not found
RET ; '
eluerr MOV BX,BP ; restore pos
RET ; "
einsch PUSH BX ; insert char in line
MOV CX,#$0001 ; 1 char
CALL eblkupdt ; update blocks
MOV DX,#lineend1 ; buffer end
XCHG BX,DX ; calc count
SUB BX,DX
DEC BX
MOV CX,BX
MOV DX,#lineend0 ; buffer end
MOV BX,DX
DEC BX
MOV.B AL,CL ; test length
OR.B AL,CH ; did they translate this automatically
JZ einscnil ; from Z80-code ??!!
PUSH DX ; save pos
CALL movebkb ; insert
POP BX ; restore pos
MOV.B [BX],#$20 ; store a space
einscnilPOP BX ; restore pos
RET ; "
ewritposCALL esetcur ; Write string + pos cursor
ewrits CALL klowvid ; LowVideo
JMP prints ; "write string
ewriterrCALL vidattr3 ; Attribute #3
JMP prints ; "write string: error message
ewritch CMP.B disflg,#$FF ; editing status
JNZ ewritret ; :ret
JMP conput ; "write it
ekbdstatPUSH AX ; Get KBD stat
PUSH BX
PUSH CX
PUSH DX
DEC SP
CALL [vkbdstat] ; do it
POP DX
POP CX
POP BX
POP AX
ewritretRET ; "
esetcur CMP.B disflg,#$00 ; set cursor pos
JZ escrt
MOV.B scrrow,BL ; line
XCHG BX,DX
CALL setcpos ; set it
XCHG BX,DX ; restore
escrt RET ; "
; first command table (installed with TINST)
ecmd1 B $01,$0D,$02,$1B,$4B,$01,$FF,$02,$1B,$4D,$02,$1B,$73,$02
B $1B,$74,$02,$1B,$48,$02,$1B,$50,$01,$FF,$01,$FF,$02,$1B
B $49,$02,$1B,$51,$02,$1B,$47,$02,$1B,$4F,$02,$1B,$77,$02
B $1B,$75,$02,$1B,$84,$02,$1B,$76,$01,$FF,$01,$FF,$01,$FF
B $02,$1B,$52,$01,$FF,$01,$FF,$01,$FF,$01,$FF,$02,$1B,$53
B $01,$08,$01,$FF,$02,$1B,$41,$02,$1B,$42,$01,$FF,$01,$FF
B $01,$FF,$01,$FF,$01,$FF,$01,$FF,$01,$FF,$01,$FF,$01,$FF
B $01,$FF,$01,$FF,$01,$FF,$01,$FF,$01,$FF,$01,$FF,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
B $00,$00,$00,$00 ; "
; second command line (preinstalled)
ecmd2 B $01,$0D,$01,$13,$01,$08,$01,$04,$01,$01,$01,$06,$01,$05
B $01,$18,$01,$17,$01,$1A,$01,$12,$01,$03,$02,$11,$13,$02
B $11,$04,$02,$11,$05,$02,$11,$18,$02,$11,$12,$02,$11,$03
B $02,$11,$02,$02,$11,$0B,$02,$11,$10,$01,$16,$01,$0E,$01
B $19,$02,$11,$19,$01,$14,$01,$07,$01,$7F,$01,$FF,$02,$0B
B $02,$02,$0B,$0B,$02,$0B,$14,$02,$0B,$08,$02,$0B,$03,$02
B $0B,$16,$02,$0B,$19,$02,$0B,$12,$02,$0B,$17,$02,$0B,$04
B $01,$09,$02,$11,$09,$02,$11,$0C,$02,$11,$06,$02,$11,$01
B $01,$0C,$01,$10,$00 ; "
eseptab B "<>,[].*+-/$:=(){}^#\'"
esepspc B " ",$00 ; "
; Jump table for editor commands
; Labels ending with 2 have the MSB set. On these commands
; the text is marked as changed. The commands are in the order
; given in the chapter "Editing Command Installation" of the
; Turbo manual.
ejmptab W ecr,eleft,eleft,eright,ewrdlft,ewrdrt,eup,edn,escrup,escrdn
W epagup,epagdn,ejlnbeg,ejlnend,epagtop,epagbot,etxtbeg
W ejtxend,ejbkbeg,ejbkend,elstpos,etogovr,elinins2,edellin2
W edeleol2,edelwrd2,edelrt2,edellft2,edellft2,emarkbeg,emarkend
W emrkwrd,ekh,eblkcpy2,eblkmov2,eblkdel2,eblkrd2,ekw,ekd
W etab2,etogind,erstlin2,e ; "
; *** Compiler ***
turbo MOV spsav,SP ; save stack pointer
CMP.B cpmode,#$02 ; to COM or CHN ?
JB turmem ; :no
CMP.B txcomp,#$00 ; is it already compiled ?
JZ turmem ; :no
CMP.B cdinval,#$00 ; is it invalid ?
JNZ turmem ; :yes
CALL opendest ; open dest file
CALL cvmemdsk ; change to disk code
JMP.b turret ; 'no error
turmem CALL inittur ; init variables
CMP.B cpmode,#$00 ; to memory ?
JNZ turfil ; :no
CALL copyrt ; make space, copy run-time lib
JMP.b turmem2 ; '
turfil CMP.B cpmode,#$02 ; COM / CHN ?
JB turmem2 ; :no
CALL opendest ; open dest file
turmem2 CALL compile ; compile program
CMP.B cpmode,#$00 ; memory ?
JNZ turfil2 ; :no
MOV.B txcomp,#$FF ; set flag: compiled
JMP.b turret ; '
turfil2 CMP.B cpmode,#$02 ; COM / CHN ?
JB turret ; :no
CALL codflush ; flush code buffer
turret XOR.B AL,AL
JMP errexit ; "return: no error
inittur MOV.B txcomp,#$00 ; Init variables: not compiled
MOV.B cdinval,#$00 ; code invalid
MOV BX,txend ; store ^Z at source end
MOV.B [BX],#$1A
MOV CL,#$04 ; (size/16)+1+DS
SHR BX,CL
INC BX
MOV AX,DS
ADD AX,BX
MOV destseg,AX ; -> code dest segment
MOV AX,freemem ; free memory - size
SUB AX,BX
MOV minstksz,AX ; -> minimum stack size
MOV DI,stackpt ; stack pointer - 1024
SUB DI,#$0400
MOV ptcend,DI ; -> end of patch list space
SUB DI,#$0400 ; - 1024
MOV ptctop,DI ; -> top of patch list
MOV ptcbeg,DI ; -> beg of patch list
DEC DI ; destination for var table
MOV SI,#stdvars ; copy std vars into symbol table
MOV CX,SS ; SS -> ES
MOV ES,CX
PUSH DS ; save DS
MOV CX,CS ; CS -> DS
MOV DS,CX
MOV CX,#$036A ; count
STD
REPZ
MOVS.B
POP DS ; restore DS
INC DI
MOV symtop,DI ; -> top of symtab
MOV symtop2,DI
MOV fence,DI ; -> current var fence
MOV BX,#varpatch ; patch in ptrs to type defs
MOV CX,#$0019
itpatch CS:
MOV BP,[BX] ; pointer
ADD [BP_DI],DI ; + offset
INC BX
INC BX ; next one
LOOP itpatch ; :another one
MOV AX,txbeg ; text beg
MOV srcptr,AX ; -> src ptr
MOV DI,#pnbuf ; line buffer
MOV chptr,DI ; -> char ptr
MOV.B [DI],#$00 ; clear line
XOR AX,AX ; clear vars:
MOV recnum,AL ; record nesting
MOV reccnt,AL
MOV lexnest,AL ; lexical nesting
MOV srcend,AL ; not end of source
MOV flgpshax,AL ; no PUSH AX
MOV flgpshes,AL ; no PUSH ES
MOV flgpshdi,AL ; no PUSH DI
MOV usrint,AL ; user int not used
MOV ovrcnt,AL ; no overlays used
MOV inclflg,AL ; no include
MOV cdptr,AX ; code ptr
MOV cdbufpt,AX ; code pos in buffer
MOV cdbegpt,AX ; beg of code buffer
MOV cdfoff,AX ; current file offset
MOV cdfoff1,AX
MOV lincnt,AX ; line counter
MOV cinpsize,AX ; std in buffer size
MOV coutsize,AX ; std out buffer size
MOV cmaxfil,#$0010 ; max 16 open files
MOV.B scalcnt,#$0D ; counter for scalar types
MOV direct,#$00ED ; set compiler directive
CALL disline ; display line, test brk
MOV pc,#$2D7C ; PC: start of code
MOV dc,#$0240 ; DC: start of file list
CMP.B cpmode,#$02 ; COM ?
JZ itcom ; :yes
JA itret ; CHN:ret
MOV cdptr,#$2D7C ; code pos of buffer
RET ; '
itcom MOV cdptr,#$2C7C ; code ptr
MOV cdbufpt,#$2C7C ; code pos of buffer
itret RET ; "
copyrt MOV AX,#start ; Test for memory overflow
MOV cdptr,AX
MOV CL,#$04 ; (../16)+1
SHR AX,CL
INC AX
ADD AX,destseg ; + dest segment
MOV BX,symtop ; (symtop/16)+SS
SHR BX,CL
MOV CX,SS
ADD BX,CX
CMP AX,BX ; compare them
CALL errnb ; 99:compiler overflow
B $63
XOR SI,SI ; clear addr
XOR DI,DI
MOV ES,destseg ; dest seg
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
MOV CX,#start ; copy runtime library into code
CLD
REPZ
MOVS.B
POP DS ; restore DS
RET ; "
opendestMOV AH,#$3C ; Open dest file
XOR CX,CX ; no attribute
MOV DX,#destpn ; dest name ptr
PUSH DS ; DS -> ES
POP ES
CALL dos ; create it
CALL errb
B $C9
MOV dstfile,AX ; store file handle
CMP.B cpmode,#$02 ; COM file ?
JNZ odret ; :no
MOV BX,AX ; file handle
MOV AH,#$40 ; write byte block
MOV CX,#$2C7C ; size of runtime code
MOV DX,#$0100 ; offset
PUSH DS ; save DS
PUSH CS ; CS -> DS
POP DS
CALL dos ; write runtime library
POP DS ; restore DS
JB oderr ; :error
CMP AX,CX ; length = expected ?
JNZ oderr ; no: error
odret RET ; '
oderr CALL err ; C9:dest file not written
B $C9 ; "
cvmemdskPUSH DS ; Change mem code to disk code
PUSH DS ; save DS
POP ES ; DS -> ES
MOV DS,destseg ; code dest segment
MOV SI,#memparm ; ptr to memory parameters
MOV DI,#pnbuf ; dest: buffer
MOV CX,#$0007 ; 7 words
CLD
REPZ
MOVS ; move it into buffer
PUSH DS ; DS -> ES
POP ES
POP DS ; restore DS
MOV DI,#memparm ; ptr to memory parameters
ES:
AND [DI],#$FFFE ; clear direct mode
MOV AX,codesize ; code size > min CS size ?
CMP AX,mincssz
JNB cvdcs ; :ok
MOV AX,mincssz ; at least min CS size
cvdcs ES:
MOV [DI]$06,AX ; store CS size
MOV AX,datasize ; data size > min DS size ?
CMP AX,mindssz
JNB cvdds ; :ok
MOV AX,mindssz ; at least min DS size
cvdds ES:
MOV [DI]$08,AX ; store DS size
MOV AX,minhpsz ; min free heap
ES:
MOV [DI]$0A,AX ; -> heap, stack size
CMP AX,maxhpsz ; > max free heap ?
JNB cvdhp ; :yes
MOV AX,maxhpsz ; take that size
cvdhp ES:
MOV [DI]$0C,AX ; store max heap,stack size
MOV AH,#$40 ; Write code to disk
MOV BX,dstfile ; dest file handle
MOV CX,cdptr ; code end
MOV DX,#start ; offset: end of run-time
SUB CX,DX ; calc length
PUSH DS ; save DS
PUSH ES ; ES -> DS
POP DS
CALL dos ; write it
POP DS ; restore DS
PUSH AX ; save results
PUSH CX
PUSHF
MOV SI,#pnbuf ; restore memory code
MOV DI,#memparm
MOV ES,destseg
MOV CX,#$0007 ; 7 words
CLD
REPZ ; do it
MOVS
POPF ; restore results
POP CX
POP AX
JB cvderr ; :error
CMP AX,CX ; length = expected ?
JNZ cvderr ; :no
RET ; '
cvderr CALL err ; C9:file error
B $C9 ; "
compile CALL skip ; Compile program: get word
CALL ctoken ; PROGRAM ?
W tkprog
JNZ comnoprm ; :no
CALL dummysym ; read dummy symbol
CALL cbrack1 ; ( ?
JNZ comprmen ; :no
comprmlpCALL dummysym ; read dummy symbol
CALL ccomma ; , ?
JZ comprmlp ; yes: repeat
CALL ebrack2 ; ! )
comprmenCALL esemi ; !
comnoprmMOV AX,#initmem ; * CALL initmem
CALL ecall ; emit CALL
XOR AX,AX ; set mode flag
CMP.B cpmode,#$00 ; to memory ?
JNZ comcom ; :no
OR AX,#$0001 ; flag: direct mode
comcom TEST direct,#$0080 ; device checking ?
JZ comdevck ; :no
OR AX,#$0002 ; set flag
comdevckTEST direct,#$0008 ; test ^C and ^S ?
JZ comctcs ; :no
OR AX,#$0004 ; set flag
comctcs PUSH AX ; save flag
PUSH cdptr ; save code ptr
CALL eword ; emit mode flag
MOV AX,CS ; emit Turbo CS
CALL eword
MOV AX,DS ; emit Turbo DS
CALL eword
PUSH cdptr ; save code ptr
CALL eword ; emit 4 dummy words:
CALL eword ; memory size is not yet known
CALL eword
CALL eword
MOV AX,cmaxfil ; max number of open files
ADD dc,AX ; add to data counter
ADD dc,AX ; (file handle list)
CALL eword ; emit file count
MOV AX,cinpsize ; std in buf size
ADD dc,AX ; add to DC
CALL eword ; emit
MOV AX,coutsize ; std out buf size
ADD dc,AX ; add to DC
CALL eword ; emit
CALL ecode ; * MOV BP,SP
B $02,$8B,$EC
MOV varspc,#$0000 ; clear var space used
CALL emcrunch ; emit overlay uncrunch
CALL defpart ; declaration part
CALL progpart ; program part
MOV DI,chptr
CMP.B [DI],#$2E
CALL errnz
B $0A
CALL ecode ; * XOR AX,AX
B $02,$33,$C0
MOV AX,#progend ; * CALL progend
CALL ecall
CALL ptcrunch ; end overlay crunch list
MOV AX,pc ; (PC+15)/16
ADD AX,#$000F
MOV CL,#$04
SHR AX,CL
MOV codesize,AX ; -> CS size
MOV AX,dc ; (DC+15)/16
ADD AX,#$000F
MOV CL,#$04
SHR AX,CL
MOV datasize,AX ; -> DS size
POP BX ; code ptr: memory sizes
MOV AX,codesize ; CS size > min CS size ?
CMP AX,mincssz
JNB comcs ; :ok
MOV AX,mincssz ; at least min CS size
comcs CALL patch ; patch in
INC BX
INC BX
MOV AX,datasize ; DS size > min DS size ?
CMP AX,mindssz
JNB comds ; :ok
MOV AX,mindssz ; at least min DS size
comds CALL patch ; patch in
INC BX
INC BX
MOV AX,minhpsz ; min free heap
CMP.B cpmode,#$02 ; COM / CHN ?
JNB comfile ; :yes
MOV AX,minstksz ; min stack size
SUB AX,codesize ; - code size - data size
SUB AX,datasize
MOV minstksz,AX ; -> min stack size
comfile PUSH AX ; save it
CALL patch ; patch in
POP AX ; restore
INC BX
INC BX
CMP AX,maxhpsz ; > max free heap size ?
JNB comhp ; :ok
MOV AX,maxhpsz ; at least max free heap
comhp CALL patch ; patch in
POP BX ; code ptr mode flag
POP AX ; flag
CMP.B usrint,#$00 ; user interrupt used ?
JZ comnobrk ; :no
OR AX,#$0008 ; set flag: user interrupt
comnobrkCALL patch ; patch in
JMP ptcflush ; "patch code in file
dummysymPUSH symtop ; read dummy symbol
CALL rdsym ; read symbol
POP symtop ; restore symtob: forget symbol read
RET ; "
chkovrflPUSH AX ; Test for overflow
PUSH BX
PUSH CX ; save regs
CMP.B cpmode,#$00 ; to memory ?
JNZ ckvfil ; :no
MOV AX,pc ; (PC/16)+1
MOV CL,#$04
SHR AX,CL
INC AX
MOV BX,dc ; +(DC/16)+64
MOV CL,#$04
SHR BX,CL
ADD BX,AX
ADD BX,#$40
CMP BX,minstksz ; >= free memory ?
CALL errnb ; 98:memory overflow
B $62
JMP.b ckvmem ; 'ok
ckvfil MOV AX,cdptr ; code ptr
SUB AX,cdbufpt ; -code pos of buffer
ADD AX,cdbegpt ; +beg of code buffer
MOV CL,#$04 ; convert to paragraphs
SHR AX,CL
INC AX
ckvmem ADD AX,destseg ; + dest segment
ADD AX,#$0020 ; + spare
MOV BX,symtop ; (symtab top/16)+SS
SHR BX,CL
MOV CX,SS
ADD BX,CX
CMP AX,BX ; crash ?
JB ckvok ; :no
PUSH DX ; save
CALL codflush ; flush code buffer
CALL errb ; 99:compiler overflow
B $63
POP DX ; restore
ckvok POP CX ; restore regs
POP BX
POP AX
RET ; "
alpha CMP AL,#$41 ; valid symbol char ?
JB alpharet ; :no
CMP AL,#$5B ; A..Z ?
CMC
JNB alpharet ; :ok
CMP AL,#$5F ; _ ?
JZ alpharet ; yes: ok
CMP AL,#$61 ; a..z ?
JB alpharet ; :no
CMP AL,#$7B
CMC
alpharetRET ; "
alphanumCALL alpha ; valid alphanumeric char ?
JNB alnret ; :ok
number CMP AL,#$30 ; 0..9 ?
JB alnret ; :no
CMP AL,#$3A
CMC
alnret RET ; "
perrb MOV chptr,DI ; Error if below: store error pos
errb JNB skiperr ; :no error
JMP.b err ; '
MOV chptr,DI ; Error if not below
errnb JB skiperr ; :no error
JMP.b err ; '
perrz MOV chptr,DI ; Error if equal
errz JNZ skiperr ; :no error
JMP.b err ; '
perrnz MOV chptr,DI ; Error if not equal
errnz JNZ err ; :error
skiperr PUSH BP ; no error: skip inline parameter
MOV BP,SP
INC [BP]$02
POP BP
RET ; '
perr MOV chptr,DI ; store error position
err POP BX ; Error: get return addr
CS:
MOV.B AL,[BX] ; get error number (inline)
errexit MOV cperr,AL ; store it
CALL disline ; write line number
OR.B AL,AL ; test error
JZ exitcom ; :no error
MOV AX,chptr ; calculate error position
SUB AX,#pnbuf ; pos in buffer - buffer beg
CMP.B inclflg,#$00 ; include file ?
JNZ errfil ; :yes
SUB AX,txbeg ; - text beg
ADD AX,srclnbeg ; + beginning of source line
JMP.b errmem ; '
errfil ADD AX,srclnbg ; pos of line begin
errmem MOV txerrpos,AX ; store relative error pos
exitcom MOV AH,#$80 ; close all files
CALL dos
MOV SP,spsav ; restore stack pointer
RET ; "return to user-interface
defpart PUSH cdptr ; Definition part: save code pointer
CALL ejump ; * JMP ....
PUSH pc ; save PC
defloop CALL ckey ; search keyword
B $01 ; offset between keywords
W tklabel ; keyword pointer
CALL errnz ; not found ?
B $0C ; 12:BEGIN expected
deflab CMP AL,#$01 ; LABEL ?
JNZ defconst ; :no
CALL label ; do label
JMP defloop ; 'next def
defconstCMP AL,#$02 ; CONST ?
JNZ deftype ; :no
CALL const ; do const
JMP deflab ; 'next def, already searched
deftype CMP AL,#$03 ; TYPE ?
JNZ defvar ; :no
CALL type ; do type
JMP deflab ; 'next def
defvar CMP AL,#$04 ; VAR ?
JNZ defover ; :no
CALL var ; do var
JMP deflab ; 'next def
defover CMP AL,#$07 ; OVERLAY ?
JNZ defproc ; :no
CALL overlay ; do overlay
JMP defloop ; 'next def
defproc CMP AL,#$08 ; BEGIN ?
JZ defend ; :yes
MOV.B ovrproc,#$00 ; flag: not overlay procedure
CALL procfunc ; do procedure / function def
JMP defloop ; 'next def
defend CALL resforw ; resolve forward definitions
POP CX ; restore beginning PC
MOV AX,pc ; new PC
SUB AX,CX ; calc offset
POP BX ; code ptr of beginning
INC BX ; +1: offset
JMP patch ; "patch it
emcrunchMOV AX,#uncrunch ; emit code for overlay uncrunch
CALL ecall ; * CALL uncrunch
MOV AX,cdptr ; code ptr
MOV uncrlink,AX ; -> link
CALL eword ; emit it (dummy)
MOV AX,pc ; PC+2
INC AX
INC AX
JMP eword ; "emit it
ptcrunchMOV BX,uncrlink ; do overlay uncrunch list
MOV AX,cdptr ; code ptr
SUB AX,BX ; - pos old link
CALL patch ; patch offset
XOR AX,AX ; emit a zero:
JMP eword ; "current end of the list
label MOV AX,#$0100 ; label definition
CALL symword ; store word in symtab
MOV DI,chptr ; current pos
MOV.B AL,[DI] ; get char
CALL alphanum ; in alphanum ?
CALL rdsym0 ; get sym - numbers allowed
MOV.B AH,lexnest ; lexical nesting
MOV AL,#$FF ; flag: unresolved
CALL symword ; store word
CALL symword ; store dummy: offset
CALL symoffs ; write symtab offset
CALL ccomma ; , ?
JZ label ; yes: do another definition
JMP esemi ; "!
const PUSH symtop ; Constant definition
XOR AX,AX ; tag: invisible
CALL symword ; store in symtab
CALL rdsym ; get symbol name
CALL cequal ; = ?
JNZ cnstruct ; no: structured constant
CALL rdconst ; read constant
MOV.B AL,CL ; type
CALL symbyte ; store in symtab
CMP.B CL,#$09 ; real ?
JNZ cnstr ; :no
MOV AX,creal3 ; store real number in symtab
CALL symword ; 6 bytes
MOV AX,creal2
CALL symword
MOV AX,creal1
CALL symword
JMP.b cnput ; 'do end of entry
cnstr CMP.B CL,#$08 ; string ?
JNZ cnint ; :no
MOV BX,#wordbuf ; buffer pointer
MOV.B AL,CH ; get length
INC.B CH ; counter
cnstlp CALL symbyte ; store byte in symtab
MOV.B AL,[BX] ; get next char
INC BX
DEC.B CH ; another ?
JNZ cnstlp ; :yes
JMP.b cnput ; 'do end of entry
cnint XCHG AX,BX ; integer constant: result -> AX
CALL symword ; store in symtab
cnput CALL symoffs ; write symtab offset
MOV AL,#$02 ; set tag: normal constant
JMP.b cnput2 ; 'do it
cnstructCALL ecolon ; ! : (structured constant)
PUSH symtop ; save symtab pos
CALL symword ; store dummy type
MOV AX,pc ; store offset in symtab
CALL symword
MOV AX,#$FE00 ; segment CS
CALL symword
CALL symoffs ; write symtab offset
CALL rdtype ; get type
POP BP ; restore symtab pos
MOV AX,vartp ; store type ptr
MOV [BP]-$02,AX
CALL eequal ; ! =
CALL structcn ; read structured constant
MOV AL,#$04 ; tag: structured constant
cnput2 POP BP ; restore symtab pos
MOV.B [BP]-$01,AL ; set tag byte: entry type
CALL esemi ; !
CALL ckey ; search keyword: definitions
B $01
W tklabel
JZ cnrt ; :found, exit
JMP const ; 'do another const definition
cnrt RET ; "
structcnMOV AL,varctp ; read structured constant
CMP AL,#$04 ; test component type
JB scnok ; :ok
CMP AL,#$08 ; file / pointer ?
JNB scnok ; :no
CALL err ; 61:Files and pointers
B $3D ; 'are not allowed here
scnok CMP AL,#$01 ; array ?
JNZ scnrec ; :no
CALL pushe1 ; save entry to stack
MOV BP,upper ; index type
CALL getparm ; get parameters
MOV AX,upper2 ; upper bound - lower bound + 1
SUB AX,lower2
INC AX
PUSH AX ; save count
MOV BP,lower ; component type pointer
CALL getvprm2 ; get parms
POP CX ; restore count
CMP.B varctp,#$0C ; array of char ?
JNZ scnarray ; :no
OR.B CH,CH ; test count
JNZ scnarray ; :more than 256
CALL cbrack1 ; ( ?
JNZ scnarrch ; no: defined by string constant
JMP.b scnarrlp ; '
scnarrayCALL ebrack1 ; ! (
scnarrlpPUSH CX ; save count
CALL structcn ; read structured constant (recursive !)
POP CX ; restore count
DEC CX ; count down
JCXZ scnaend ; :done
CALL ecomma ; ! ,
JMP scnarrlp ; 'do next entry
scnarrchPUSH CX ; save count
CALL rdstrcn ; read constant
POP DX ; restore expected length
CMP.B CH,DL ; = length read ?
CALL errnz ; 50:String const length does not
B $32 ; match type
CALL estr2 ; emit string (without length byte)
JMP.b scnaend2 ; 'done
scnaend CALL ebrack2 ; ! )
scnaend2CALL pope1 ; restore entry
RET ; '
scnrec CMP AL,#$02 ; record ?
JNZ scset ; :no
CALL pushe1 ; save entry to stack
CALL ebrack1 ; ! (
MOV.B CL,varnest ; record nesting level
PUSH varsize ; save component size
XOR AX,AX ; offset in record: size done
scnrlp PUSH CX ; save nesting, size
PUSH AX
MOV CH,#$04 ; search variable
CALL search
CALL errnz ; 41:Unknown ID or syntax error
B $29
CALL getvprm ; get parms
POP AX ; restore size
CMP AX,varofs ; = offset of record sub-var ?
CALL errnz ; 69:Invalid ordering of fields
B $45
ADD AX,varsize ; add size to offset
PUSH AX ; save it
CALL ecolon ; ! :
CALL structcn ; read structured constant
CALL csemi ; , ?
POP AX ; restore size, nesting level
POP CX
JZ scnrlp ; yes: continue
PUSH AX ; save size
CALL ebrack2 ; ! )
POP AX ; current size
POP CX ; component size of record type
SUB CX,AX ; compare them
JZ scnrok ; :ok
scnrfillXOR.B AL,AL ; emit zeroes to fill
CALL ebyte
LOOP scnrfill ; :another
scnrok CALL pope1 ; restore entry from stack
RET ; '
scset CMP AL,#$03 ; set ?
JNZ scstr ; :no
CALL pushe1 ; save entry to stack
PUSH varsize ; save component size
MOV BP,lower ; type ptr
CALL getvprm2 ; get type parms
CALL esqr1 ; ! [
MOV DI,#wordbuf ; buffer ptr
PUSH DS ; DS,DI: dest ptr
PUSH DI
CALL sldempty ; make empty set (on stack)
CALL csqr2 ; ] ?
JZ scssto ; :yes
scslp CALL rdscalar ; get scalar element
PUSH AX ; save
CALL ctoken
W tk2dot
JNZ scsincl ; :no
CALL rdscalar ; get scalar element
CALL setinrng ; include range in set
JMP.b scsrng ; '
scsincl POP AX ; restore scalar element
CALL setincl ; include element in set
scsrng CALL ccomma ; , ?
JZ scslp ; yes: continue
CALL esqr2 ; ! ]
scssto MOV CX,#$0020 ; 32 bytes
CALL setsto ; store set into buffer
MOV BX,lower ; crunch set constant:
MOV CL,#$03 ; (lower bound)/8
SHR BX,CL
ADD BX,#wordbuf ; + buffer offset
POP CX ; restore component size
scsemit MOV.B AL,[BX] ; get byte
CALL ebyte ; emit it
INC BX ; next one
LOOP scsemit ; :another
CALL pope1 ; restore entry from stack
RET ; '
scstr CMP AL,#$08 ; string ?
JNZ screal ; :no
CALL rdstrcn ; read string constant
MOV.B CL,varsize ; component size - 1
DEC.B CL
SUB.B CL,CH ; >= actual size ?
JNB scstok ; :ok
ADD.B CL,CH ; limit to max size
MOV.B CH,CL
XOR.B CL,CL ; nothing to fill up
scstok CALL estring ; emit string
OR.B CL,CL ; fill up ?
JZ scstret ; :no
scstfillXOR.B AL,AL ; emit zeroes to reserve space
CALL ebyte
DEC.B CL ; another ?
JNZ scstfill ; :yes
scstret RET ; '
screal CMP AL,#$09 ; real ?
JNZ scint ; :no
CALL rdnumcn ; get numeric constant
CMP.B CL,#$09 ; real ?
JZ scrok ; :ok
CMP.B CL,#$0A ; integer ?
CALL errnz ; 25:Integer or real const expected
B $19
XCHG AX,BX ; get result
CALL intreal ; convert to real
MOV creal1,AX ; store it in buffer
MOV creal2,BX
MOV creal3,DX
scrok MOV AX,creal1 ; emit resulting real number
CALL eword
MOV AX,creal2
CALL eword
MOV AX,creal3
JMP eword ; 'done
scint CALL rdscalar ; integer: get scalar element
CMP varsize,#$01 ; component size = 1 ?
JZ scbyte ; :yes
JMP eword ; 'emit word
scbyte JMP ebyte ; "emit byte
rdscalarCALL rdnumcn ; get scalar element
CMP.B CL,varctp ; = component type ?
CALL errnz ; 44:Type mismatch
B $2C
XCHG AX,BX ; result -> AX
CMP AX,lower ; < lower bound ?
JL rscalerr ; :yes
CMP AX,upper ; > upper bound ?
JG rscalerr ; :yes
RET ; '
rscalerrCALL err ; 45:Constant out of range
B $2D ; "
type PUSH symtop ; Type definition
typelp PUSH symtop ; save symtab top
MOV AX,#$0000 ; tag: invisible
CALL symword ; store in symtab
CALL rdsym ; get symbol
PUSH symtop ; save symtab top
CALL symword ; store dummy
CALL symoffs ; write symtab offset
CALL eequal ; ! =
CALL rdtype ; get type
POP BP ; restore pos
MOV AX,vartp ; store type ptr
MOV [BP]-$02,AX
POP BP ; pos of tag
MOV.B [BP]-$01,#$03 ; set tag: type definition
CALL esemi ; !
CALL ckey ; search keyword: definitions
B $01
W tklabel
JNZ typelp ; not found: another type def
POP tyfence ; old symtab top -> type fence
PUSH AX ; save next element
CALL resptr ; fill in pointer types
POP AX ; restore next element
RET ; "
var CALL vardef ; Var definition: define var
CALL esemi ; !
CALL ckey ; search keyword: definitions
B $01
W tklabel
JNZ var ; not found: another var
RET ; "
overlay MOV.B cdinval,#$FF ; Overlay: always recompile
MOV DI,#destpn ; get filename
XOR DX,DX ; end pos
ovnm1 MOV.B AL,[DI] ; get char
OR.B AL,AL ; end ?
JZ ovnmend ; :yes
CMP AL,#$2E ; . ?
JNZ ovnm2 ; :no
MOV DX,DI ; remember end pos
ovnm2 INC DI ; next char
CMP AL,#$5C ; \ ?
JNZ ovnm1 ; no: loop back
MOV BX,DI ; set beg position
XOR DX,DX ; clear end position
JMP ovnm1 ; 'loop
ovnmend OR DX,DX ; end position set ?
JZ ovnm3 ; :no
MOV DI,DX ; set it
ovnm3 CMP DI,#destpne ; too much ?
CALL errnb ; 92:Unable to create overlay file
B $5C
MOV AL,ovrcnt ; overlay counter
XOR.B AH,AH ; clear high byte
INC.B ovrcnt ; count up
MOV [DI],#$302E
MOV CL,#$0A ; get 10-digit
DIV.B CL
ADD AX,#$3030 ; -> ASCII
MOV [DI]$02,AX ; store number
MOV.B [DI]$04,#$00 ; mark end
MOV AX,#rdover ; * CALL readovr
CALL ecall
MOV AX,#$FFFF ; invalid overlay in mem
CALL eword ; emit word
MOV CX,#$000D ; 13 bytes
ovnmem MOV.B AL,[BX] ; emit file name
CALL ebyte
INC BX
LOOP ovnmem ; :another
CALL ptcflush ; patch code in file
CALL codflush ; flush code buffer
MOV AL,cpmode ; save code destination
PUSH AX
PUSH dstfile ; save dest file handle
PUSH cdptr ; save code ptr
PUSH cdbufpt ; save code pos buf beg
PUSH cdbegpt ; save beg of buf
PUSH cdfoff ; save current offset in file
PUSH cdfoff1
PUSH uncrlink ; save uncrunch link
PUSH ovrlen ; save max length of overlay part
CMP.B cpmode,#$00 ; compile to memory ?
JNZ ovfil ; :no
MOV.B cpmode,#$02 ; set: to COM
ovfil MOV AX,cdptr ; code ptr - code pos of buffer
SUB AX,cdbufpt ; add to beg of code buffer
ADD cdbegpt,AX
XOR AX,AX ; length = 0
MOV ovrlen,AX
MOV cdfoff,AX ; no offset in file
MOV cdfoff1,AX
CMP.B cpmode,#$01 ; find error ?
JZ ovloop
MOV AH,#$3C ; create file
XOR CX,CX ; no attribute
MOV DX,#destpn ; name ptr
PUSH DS ; DS -> ES
POP ES
CALL dos ; open it
CALL errb ; 92:Unable to create overlay file
B $5C
MOV dstfile,AX ; store dest file handle
ovloop XOR AX,AX
MOV cdptr,AX ; clear code ptr
MOV cdbufpt,AX ; code pos of buffer
CALL ckey ; search key word
B $01 ; (procedure or function)
W tkproc
CALL errnz ; 16:PROC or FUNC expected
B $10
PUSH pc ; save PC
PUSH cdptr ; save code ptr
PUSH AX ; save keyword
CALL emcrunch ; emit overlay uncrunch code
POP AX ; restore keyword
MOV.B ovrproc,#$FF ; set flag: in overlay
CALL procfunc ; do proc/func
CALL ptcrunch ; end overlay uncrunch list
CALL ptcflush ; patch code in file
POP CX ; restore code ptr, PC
POP DX
PUSH BP ; save
ovfill MOV AX,cdptr ; new - old code ptr
SUB AX,CX
OR.B AL,AL ; emit zeroes, until length
JZ ovnofill ; a multiple of 256
XOR.B AL,AL
CALL ebyte
JMP ovfill ; '
ovnofillPOP BP ; restore
MOV [BP]-$0E,AX ; store code pos in proc def
ADD cdfoff,AX ; add to pos in file
ADC cdfoff1,#$00
MOV AX,pc ; PC - old PC
SUB AX,DX
MOV pc,DX ; restore old PC
CMP AX,ovrlen ; >= previous procedures ?
JB ovshort ; :no
MOV ovrlen,AX ; set as max length
ovshort CALL codflush ; flush code buffer
CALL ctoken ; OVERLAY ?
W tkover
JZ ovloop ; yes: repeat
CMP.B cpmode,#$01 ; find error ?
JZ ovfind ; yes: no file
MOV AH,#$3E ; close file
MOV BX,dstfile ; file handle
CALL dos
ovfind MOV DX,ovrlen ; get maximum length
POP ovrlen ; restore variables
POP uncrlink ; same as above
POP cdfoff1
POP cdfoff
POP cdbegpt
POP cdbufpt
POP cdptr
POP dstfile
POP AX
MOV cpmode,AL ; restore code destination
ADD DX,pc ; max length + PC
MOV BX,uncrlink ; uncrunch link
MOV AX,cdptr ; code ptr -> uncrunch link
MOV uncrlink,AX
SUB AX,BX ; code pos - link
CALL patch ; patch link
CALL eword ; emit word
MOV AX,DX ; max length + PC
CALL eword ; emit word
MOV pc,DX ; set new PC
RET ; "
procfuncMOV procfnc,AL ; define proc / func: set flag
MOV.B CH,AL ; -> type
XOR.B CL,CL
PUSH CX ; save type
CALL srchvar ; search
POP AX
JNZ prfnew ; not found: new definition
JMP prffwd ; 'complete forward definition
prfnew CALL symword ; store tag word in symbol table
CALL rdsym ; get symbol
PUSH fence ; save current var fence
MOV AX,symtop2 ; current sym top
MOV fence,AX ; -> new var fence
PUSH symtop ; save symtab pos
SUB symtop,#$10 ; make space
CALL chkovrfl ; test overflow
MOV BX,#$0004 ; size of stack frame
XOR CX,CX ; parameter counter
CALL cbrack1 ; ( ?
JNZ prfnil ; no:no parms
prfloop PUSH BX ; save
PUSH CX
PUSH symtop ; save symtab pos
SUB symtop,#$04 ; make space
CALL chkovrfl ; test overflow
CALL ctoken ; VAR ?
W tkvar
MOV CX,#$0000 ; normal: 0
JNZ prfcnt ; no: normal
DEC.B CH ; flag: FF00
prfcnt PUSH CX ; save flag
CALL rdsym ; read symbol
POP CX ; restore type
INC.B CL ; count vars of same type
CALL ccomma ; , ?
JZ prfcnt ; yes: repeat
PUSH CX ; save count
OR.B CH,CH ; VAR-parameter ?
JNZ prfnotyp ; :yes
CALL ecolon ; ! :
JMP.b prftype ; '
prfnotypCALL ccolon ; : ?
JZ prftype ; yes: ok
MOV AX,ptcbeg ; bottom of symtab
SUB AX,#$000E ; point to untyped var
MOV vartp,AX ; -> type ptr
JMP.b prfnot2 ; '
prftype MOV.B flgvar,CH ; set VAR flag
CALL testtp ; get type
CALL tstscal ; limit component size
prfnot2 POP CX ; restore type, count
POP BP ; restore symtab pos
MOV AX,vartp ; type ptr
MOV [BP]-$02,AX ; -> type
MOV [BP]-$04,CX ; store count
MOV AX,varsize ; component size
OR.B CH,CH ; VAR-parameter ?
JZ prfnovar ; :no
MOV AX,#$0004 ; size 4: pointer
prfnovarXOR.B CH,CH ; clear hi
MUL CX ; count * component size
POP CX
POP BX ; restore
ADD BX,AX ; add to size of stack frame
INC.B CL ; count entries
CALL csemi ; semicolon ?
JZ prfloop ; yes: another parm
CALL ebrack2 ; ! )
prfnil CALL symoffs ; write symtab offset
CMP.B procfnc,#$06 ; function ?
JNZ prfprc1 ; :no
CALL ecolon ; ! :
PUSH BX ; save parm count,
PUSH CX ; stack frame size
MOV.B flgvar,#$00 ; clear flag: normal var
CALL testtp ; get type
POP CX ; restore
POP BX
CMP.B varctp,#$08 ; legal type ?
JNB prfresok ; :no
CMP.B varctp,#$04 ; pointer ?
CALL errnz ; 48:Invalid result type
B $30
prfresokPOP BP ; symtab ptr
PUSH BP
MOV AX,vartp ; get type ptr
MOV [BP]-$02,AX ; store it
MOV [BP]-$04,BX ; store stack frame size
MOV.B AH,lexnest ; lexical nesting level
INC.B AH ; +1
MOV AL,#$FF
MOV [BP]-$06,AX ; store segment
ADD BX,varsize ; add to size of stack frame
prfprc1 CALL esemi ; !
POP BP ; restore symtab ptr
POP AX ; restore var fence
MOV fence,AX
MOV AX,pc ; get PC
CMP.B ovrproc,#$00 ; overlay procedure ?
JZ prfnoovr ; :no
SUB AX,#$0019 ; entry code...
prfnoovrMOV [BP]-$08,AX ; store position
MOV [BP]-$0A,BX ; store stack frame size
XOR.B CH,CH ; store param count
MOV [BP]-$10,CX
MOV AX,cdprcoff ; position in overlay file
MOV [BP]-$0C,AX
MOV [BP]-$0E,#$0000 ; no forward
CMP.B ovrproc,#$00 ; overlay procedure ?
JNZ prfovr ; :yes
CALL ctoken ; FORWARD ?
W tkforwrd
JNZ prfnofwd ; :no
MOV AX,cdptr ; remember code position
MOV [BP]-$0C,AX ; for patching
DEC.B [BP]-$0F ; set flag: forward def
CALL ejump ; emit jump
JMP esemi ; '!
prfnofwdCALL ctoken ; EXTERNAL ?
W tkext
JNZ prfovr ; :no
JMP rdextnal ; 'do external procedure
prffwd CMP.B [BP]-$0F,#$00 ; complete forward definition
CALL errz ; test flag. Defined:
B $2B ; 43:Duplicate ID or label
CMP.B ovrproc,#$00 ; overlay procedure ?
CALL errnz ; yes:
B $4C ; 76:Overlays cannot be forwarded
CALL skipdi ; skip spaces
CALL esemi ; !
MOV.B [BP]-$0F,#$00 ; clear forward flag
MOV BX,[BP]-$0C ; get addr of forward jump
INC BX
MOV AX,pc ; PC-proc pos-3 -> offset
SUB AX,[BP]-$08
SUB AX,#$0003
CALL patch ; patch it in
prfovr PUSH varspc ; save memory usage
PUSH fence ; save fence
MOV AX,symtop ; symtab top
MOV fence,AX ; -> current fence
PUSH BP ; save pos in symtab
MOV AX,[BP]-$0A ; get stack frame size
CMP.B procfnc,#$05 ; procedure ?
JZ prfprc2 ; :yes
MOV BX,[BP]-$02 ; subtract size of result
SS:
SUB AX,[BX]-$02
prfprc2 MOV varspc,AX ; -> memory usage
INC.B lexnest ; inc nesting
MOV.B [BP]-$06,#$00
MOV.B CL,[BP]-$10 ; parameter count
MOV BX,BP ; pos
SUB BX,#$10
prfsto OR.B CL,CL ; all parms done ?
JZ prfentry ; :yes
PUSH CX ; save count
SS:
MOV BP,[BX]-$02 ; get variable pointer
PUSH BX ; save current pos
MOV vartp,BP ; set type ptr
CALL getvprm2 ; get var parms
POP BX ; restore pos
SS:
MOV CX,[BX]-$04 ; get type
MOV.B flgvar,CH
XOR.B CH,CH
PUSH CX ; save type
PUSH symtop ; save symtab top
SUB BX,#$04 ; go down
prfsto2 MOV BP,symtop ; symtab top
DEC BP
DEC BP
MOV [BP]$00,#$0400 ; store: var
DEC BX
DEC BP
SS:
MOV.B DL,[BX] ; get length
MOV.B [BP]$00,DL ; store length
prfsto3 DEC BX ; go down
DEC BP
SS:
MOV.B AL,[BX] ; get char
MOV.B [BP]$00,AL ; store it
DEC.B DL ; another ?
JNZ prfsto3 ; :yes
SUB BP,#$06 ; go down
MOV symtop,BP ; set new symtab top
CALL symoffs ; write offset
LOOP prfsto2 ; :another var
POP BP ; restore pos
POP CX ; restore count
PUSH BX
CALL rdvnrm ; store offset, segment
CALL tstscal ; scalar var: 2 bytes on stack
CALL vardef2 ; do var definitions
POP BX ; restore pos, cnt
POP CX
DEC.B CL ; another ?
JMP prfsto ; '
prfentryCALL ecode ; emit stack frame code
B $01,$55 ; * PUSH BP
CMP.B lexnest,#$01 ; lexical nesting = 1 ?
JNZ prflong ; :no
CALL ecode
B $02,$8B,$EC ; * MOV BP,SP
JMP.b prfshort ; '
prflong CALL ecode ; complicated - do display
B $02,$8B,$C4 ; * MOV AX,SP
XOR.B CH,CH
MOV.B CL,lexnest ; lexical nesting -> count
DEC.B CL
prfcopy CALL ecode ; * PUSH [BP+..]
B $02,$FF,$76
DEC.B CH ; count down two bytes
DEC.B CH
MOV.B AL,CH ; offset into display
CALL ebyte ; emit offset
DEC.B CL ; another level ?
JNZ prfcopy ; :no
CALL ecode
B $02,$8B,$E8 ; * MOV BP,AX
prfshortCALL ecode ; now push current display !
B $01,$55 ; * PUSH BP
MOV AL,lexnest ; lexical nesting * 2
XOR.B AH,AH
ADD AX,AX
NEG AX
MOV varspc,AX ; -> stack usage
PUSH AX
MOV AL,procfnc ; proc or func ?
PUSH AX ; save flag
CALL defpart ; do definition part
POP AX ; restore... (defs may be recursive)
MOV procfnc,AL
POP AX
SUB AX,varspc ; mem usage - current
CALL allotstk ; make space on stack
POP BP ; restore symtab ptr
PUSH BP
PUSH [BP]-$0A ; store memory size
MOV AX,varspc ; memory usage
NEG AX
ADD [BP]-$0A,AX ; add to mem size
CALL errb ; 98:Memory overflow
B $62
CALL progpart ; do program part
POP AX ; restore memory size - 4
SUB AX,#$0004
CMP.B procfnc,#$06 ; function ?
JNZ prfret ; :no
POP BP ; restore symtab pos
PUSH BP
PUSH AX ; save mem size
CALL getvprm ; get var parms
MOV.B indflg,#$00 ; flag: not indexed
POP AX ; mem size
CMP.B varctp,#$09 ; component type = real ?
JNZ prfstr ; :no
SUB AX,#$0006 ; 6 bytes on stack
JMP.b prfret ; '
prfstr CMP.B varctp,#$08 ; string ?
JNZ prfelse ; :no
SUB AX,varsize ; - component size -> pos on stack
CALL emovdxi ; * MOV DX,..
MOV AX,varsize ; component size: max length - 1
DEC AX
MOV.B AH,AL ; max string length
MOV AL,#$B1 ; * MOV CL,..
CALL eword
CALL ecode ; * MOV SP,BP
B $03,$8B,$E5,$5D ; * POP BP
MOV AX,#retstr ; * JMP retstr
CALL ejump
JMP.b prfret2 ; '
prfelse PUSH AX ; save pos
CALL eload ; load var
POP AX ; restore
CMP.B varctp,#$0B ; boolean ?
JNZ prfret ; :no
CALL ecode ; * OR AX,AX (set flags)
B $02,$0B,$C0
prfret CALL ecode ; * MOV SP,BP
B $03,$8B,$E5,$5D ; * POP BP
OR AX,AX ; stack frame ?
JNZ prfretn ; :yes
CALL ecode ; none:
B $01,$C3 ; * RET
JMP.b prfret2 ; '
prfretn CALL ecode ; remove stack frame
B $01,$C2 ; * RET ....
CALL eword ; emit stack frame size
prfret2 CALL esemi ; !
POP BP ; restore symtab pos
DEC.B [BP]-$06 ; clear flag
DEC.B lexnest ; restore lexical nesting
MOV AX,fence ; fence -> symtab top
MOV symtop,AX ; = remove all local vars
MOV symtop2,AX
POP fence ; restore fence
POP varspc ; restore mem usage
RET ; "
rdextnalPUSH BP ; read external proc
MOV CX,#$0500 ; tag: procedure
CALL search
JZ rdxold ; : found
MOV CX,#$0600 ; tag: function
CALL search
JNZ rdxnew ; :not found
rdxold PUSH [BP]-$08 ; get offset
CALL esqr1 ; ! [
CALL rdintcn ; get integer constant
CALL esqr2 ; ! ]
POP AX ; offset + number
ADD AX,BX
JMP.b rdxsto ; '-> offset of this proc
rdxnew PUSH pc ; save PC
CALL rdstrcn ; read string constant
MOV.B BL,CH ; length
XOR.B BH,BH
MOV.B [BX]wordbuf,#$00 ; store a 0 at the end
MOV BX,#wordbuf ; name ptr
MOV SI,#extcom ; extension .COM
CALL kextdef ; parse filename
MOV AX,#$3D00 ; open file
MOV DX,#scrpn ; name ptr
PUSH DS ; DS -> ES
POP ES
CALL dos ; open it
CALL errb ; 90:File not found
B $5A
MOV BX,AX ; file handle
rdxloop MOV AH,#$3F ; read from file
MOV CX,#$0080 ; 128 bytes
MOV DX,#wordbuf ; dest buffer
CALL dos ; do it
CALL errb ; 90:File not found
B $5A
XCHG AX,CX ; length read -> CX
JCXZ rdxend ; 0: end
MOV SI,#wordbuf ; source ptr
rdxcopy MOV.B AL,[SI] ; get byte from external file
CALL ebyte ; and emit it
INC SI ; next one
LOOP rdxcopy ; :again
JMP rdxloop ; 'try another block
rdxend MOV AH,#$3E ; close file
CALL dos
POP AX ; restore offset
rdxsto POP BP ; restore symtab pos
MOV [BP]-$08,AX ; store offset
JMP esemi ; "!
tstscal CMP.B varctp,#$0A ; scalar var ?
JB tsc2 ; :no
MOV varsize,#$0002 ; on stack at least 2 bytes
tsc2 RET ; "
resforw MOV BP,symtop ; Resolve forward definitions
rfwloop CMP BP,fence ; = var fence ?
JZ rfwret ; yes: end
ADD BP,[BP]$00 ; go to next entry
CMP.B [BP]-$01,#$06 ; function ?
JZ rfwfunc ; :yes
CMP.B [BP]-$01,#$05 ; procedure ?
JNZ rfwloop ; :no, next one
rfwfunc MOV BX,BP ; entry ptr
SUB BX,#$03
SS:
MOV.B AL,[BX] ; length of name
XOR.B AH,AH
SUB BX,AX ; go down
SS:
CMP.B [BX]-$0F,#$00 ; defined ?
CALL errnz ; no:
B $49 ; 73:Undefined FORWARD procedure
JMP rfwloop ; 'next one
rfwret RET ; "
vardef MOV.B flgvar,#$00 ; define var: clear VAR-flag
CALL rdvarlst ; get variable list
PUSH CX ; save counter
PUSH BP ; save symtab ptr
CALL ecolon ; ! :
CALL rdvartp ; get type, test absolute
POP BP ; restore
POP CX
vardef2 MOV DX,varsize ; component size
CMP.B flgvar,#$00 ; VAR-parameter ?
JZ vdvar ; :no
MOV DX,#$0004 ; yes: pointer !
vdvar MOV AX,var3ofs ; var offset
CMP.B absflg,#$00 ; absolute ?
JNZ vdstore ; :yes
CMP.B recnum,#$00 ; record nesting level ?
JNZ vdrec ; :in record
CMP.B lexnest,#$00 ; inside procedure ?
JNZ vdstk ; :yes
MOV AX,dc ; DC -> offset
ADD dc,DX ; add size to DC
CALL errb ; overflow:
B $62 ; 98:Memory overflow
JMP.b vdstore ; '
vdstk SUB varspc,DX ; go down (stack !)
CALL errb ; overflow ?
B $62 ; 98:Memory overflow
MOV AX,varspc ; get offset
JMP.b vdstore ; '
vdrec MOV AX,varspc ; get offset
ADD varspc,DX ; add to var space
CALL errb ; overflow ?
B $62 ; 98:memory overflow
vdstore SUB BP,#$03 ; go down in var list
MOV.B BL,[BP]$00 ; get length
XOR.B BH,BH
SUB BP,BX ; go down
MOV [BP]-$04,AX ; store offset
MOV AX,var3seg ; store segment
MOV [BP]-$06,AX
MOV AX,vartp ; store type ptr
MOV [BP]-$02,AX
SUB BP,#$08 ; make space
LOOP vdvar ; another definition ?
JMP chkovrfl ; "test for overflow
rdvarlstPUSH symtop ; get variable list
XOR CX,CX ; clear counter
rdvloop PUSH CX ; save
MOV AH,#$04 ; tag: var, record nesting
MOV AL,recnum
CALL symword ; store in symtab
CALL rdsym ; store name in symtab
SUB symtop,#$06 ; reserve some space
CALL symoffs ; write symtab offset
POP CX ; restore counters
INC CX
CALL ccomma ; , ?
JZ rdvloop ; yes: next var
POP BP ; restore symtab pos
RET ; "(beginning of list)
rdvartp PUSH symtop ; get var type, test ABSOLUTE
CALL rdtype ; read type
POP tyfence ; symtab top -> type fence
CALL resptr ; fill in pointer types
CALL ctoken ; ABSOLUTE ?
W tkabs
JNZ rdvnrm ; :no
MOV.B absflg,#$FF ; set flag
CMP.B recnum,#$00 ; in record ?
CALL errnz ; yes:
B $4B ; 75:Illegal use of ABSOLUTE
MOV CX,#$0400 ; search var
CALL search
JNZ rdvabs ; :not found
MOV AX,[BP]-$06 ; get offset
MOV DX,[BP]-$04 ; get segment
JMP.b rdvofs ; 'store parms
rdvabs CALL rdconst ; read constant -> segment
JNZ rdvseg ; :no good
CALL testint ; test type: integer
PUSH BX ; save segment
CALL ecolon ; ! :
CALL rdintcn ; get integer constant
MOV DX,pc ; get PC: pos of pointer
XCHG AX,BX
CALL eword ; emit result = offset
POP AX ; emit segment
CALL eword
MOV AX,#$FEFF ; flag: CS indirect
JMP.b rdvofs ; '
rdvseg CALL ctoken ; DSEG ?
W tkdseg
MOV AX,#$FF00 ; flag: DS
JZ rdvseg2 ; :yes
CALL ctoken ; CSEG ?
W tkcseg
MOV AX,#$FE00 ; flag: CS
JZ rdvseg2 ; :yes
JMP snerror ; 'Unknown ID or syntax error
rdvseg2 PUSH AX ; save segment flag
CALL ecolon ; ! :
CALL rdintcn ; get integer constant
POP AX ; restore segment
MOV DX,BX ; offset -> DX
rdvofs MOV var3ofs,DX
JMP.b rdvsto ; '
rdvnrm MOV.B absflg,#$00 ; clear absolute flag
MOV AL,flgvar ; VAR-parameter ?
MOV.B AH,lexnest ; lexical nesting
OR.B AH,AH ; inside proc ?
JNZ rdvofs ; :yes, use stack segment
MOV AH,#$FF ; data segment
rdvsto MOV var3seg,AX ; store segment
RET ; "
testtp CALL srchtype ; Test file type: search type
JZ ttpsto ; :found
CALL ctoken ; TEXT ?
W tktext
JNZ ttpnotxt ; :no
CALL textstd ; get ptr to that type
JMP.b ttpsto ; '
ttpnotxtCALL ctoken ; FILE ?
W tkfile
CALL errnz ; no:
B $24 ; 36:Type ID expected
CALL filuntp ; point to typed/untyped file
ttpsto CMP.B flgvar,#$00 ; VAR-parameter ?
JNZ rdvnrm ; yes: ok
CMP.B varctp,#$05 ; typed file ?
JB rdvnrm ; :below
CMP.B varctp,#$07 ; above file ?
JA rdvnrm ; yes: ok
CALL err
B $43 ; "67:Files must be VAR parameters
resptr MOV BP,symtop ; Fill in pointer types
rptlp CMP BP,tyfence ; = type fence ?
JZ rptret ; yes: done
ADD BP,[BP]$00 ; go to next var
CMP.B [BP]-$01,#$08 ; subtype ?
JNZ rptlp ; no: next one
MOV.B [BP]-$01,#$00 ; make it invisible
CMP.B [BP]-$0A,#$04 ; pointer ?
JNZ rptlp ; no: next one
CMP.B [BP]-$09,#$00 ; filled in ?
JZ rptlp ; :yes
MOV.B [BP]-$09,#$00 ; flag: filled in
MOV BX,[BP]-$08 ; get pos of type name
SS:
MOV.B DL,[BX]-$01 ; name length
XOR.B DH,DH
INC DX ; -> count
PUSH BP ; save pos
MOV BP,symtop ; search from top
rptsrch CMP BP,ptcbeg ; bottom of symbol table ?
JZ rpterr ; yes: error
ADD BP,[BP]$00 ; go to next var
CMP.B [BP]-$01,#$03 ; type ?
JNZ rptsrch ; :no, search next
MOV SI,BP ; pointer
DEC SI
DEC SI
MOV DI,BX ; pos of searched string
MOV CX,DX ; len -> count
rptcmp DEC SI ; go back
DEC DI
SS:
MOV.B AL,[SI] ; compare chars
SS:
CMP.B AL,[DI]
JNZ rptsrch ; :not the right one
LOOP rptcmp ; :test another char
POP BP ; restore symtab pos
SS:
MOV AX,[SI]-$02 ; get type pointer
MOV [BP]-$08,AX ; store into pointer entry
JMP rptlp ; 'next one
rptret RET ; '
rpterr CALL err ; 42:Undefd ptr type in preceding
B $2A ; "type defs
rdtype CALL srchtype ; get type: search type ID
JZ rdtpret ; found: ret
CALL ctoken ; PACKED ?
W tkpacked ; (ignored)
CALL array ; array ?
JZ rdtpret ; :done
CALL record ; record ?
JZ rdtpret ; :done
CALL set ; set ?
JZ rdtpret ; :done
CALL pointer ; pointer ?
JZ rdtpret ; :done
CALL file ; file ?
JZ rdtpret ; :done
CALL text ; text ?
JZ rdtpret ; :done
CALL string ; string ?
JZ rdtpret ; :done
CALL scalar ; scalar list ?
JZ rdtpret ; :done
CALL subrange ; subrange ?
JZ rdtpret ; :done
CALL err ; 36:Type identifier expected
B $24 ; '
rdtpret RET ; "
srchtypeMOV CX,#$0300 ; search type
CALL search
JNZ srtret ; :not found - ret
MOV BP,[BP]-$02 ; type pointer
stdtype MOV vartp,BP ; store it
CALL getvprm2 ; get type parms
XOR AX,AX ; ok
srtret RET ; "
array CALL ctoken ; ARRAY ?
W tkarray
JNZ arret ; :no
CALL esqr1 ; ! [
XOR CX,CX ; clear dimension count
arrlp PUSH CX ; save
CALL rdscaltp ; get scalar type
POP CX
PUSH vartp ; save type pointer: index type
MOV AX,upper ; upper bound - lower bound
SUB AX,lower
INC AX ; + 1
CALL errz ; 98:Memory overflow
B $62
PUSH AX ; save component count
INC CX ; count dimensions
CALL ccomma ; , ?
JZ arrlp ; yes: another dimension
PUSH CX ; save dim count
CALL esqr2 ; ! ]
CALL expof ; ! OF
CALL rdtype ; get type
POP CX ; dim count
arrlp2 MOV AX,vartp ; type ptr
MOV lower,AX ; -> type
MOV AX,varsize ; component size
POP BX ; * component count
MUL BX
CALL errb ; too much ?
B $62 ; 98:Memory overflow
MOV varsize,AX ; -> component size
POP AX ; index type
MOV upper,AX ; store it
MOV.B varctp,#$01 ; tag: array
CALL stotype ; store type
LOOP arrlp2 ; :another dimension
arret RET ; "
record CALL ctoken ; RECORD ?
W tkrec
JNZ recret ; no: ret
MOV AL,vrecflg ; save variant rec nesting
PUSH AX
MOV AL,recnum ; save rec nesting
PUSH AX
INC.B reccnt ; one more level
MOV AL,reccnt ; record counter
MOV recnum,AL ; -> record number
PUSH varspc ; save space used
PUSH maxsize ; save max size of variant rec
MOV varspc,#$0000 ; clear them
MOV maxsize,#$0000
MOV.B vrecflg,#$00 ; no variant record
CALL recdef ; do record definition
MOV AX,maxsize ; max component size
MOV varsize,AX ; -> variable size
POP maxsize ; restore vars
POP varspc
MOV AL,recnum ; record number
MOV varnest,AL ; -> subtype
POP AX
MOV recnum,AL
POP AX
MOV vrecflg,AL
MOV.B varctp,#$02 ; type: record
CALL stotype ; store type
recret RET ; "
recdef CALL rectest ; do record def: test end
JZ rcdret ; yes: ret
CALL ctoken ; CASE ?
W tkcase
JZ rcdvrec ; :yes
CALL vardef ; define variables
MOV AX,varspc ; memory used
CMP AX,maxsize ; >= max size ?
JB rcdsmall ; below: forget
MOV maxsize,AX ; store as new max size
rcdsmallCALL csemi ; semicolon ?
JZ recdef ; yes: loop back
JMP.b rcde ; 'end it
rcdvrec CALL srchtype ; variant record: search type
JZ rcdnotag ; :found
CALL vardef ; define var: tag field
rcdnotagCALL expof ; ! OF
rcdvlp CALL rectest ; test for end
JZ rcdret ; yes: ret
PUSH varspc ; save mem used
rcdtag CALL rdnumcn ; get constant
CALL ccomma ; , ?
JZ rcdtag ; :another constant
CALL ecolon ; ! :
CALL ebrack1 ; ! (
MOV AL,vrecflg ; save variant rec flag
PUSH AX
MOV.B vrecflg,#$FF ; set it
CALL recdef ; do type definition list
POP AX ; restore flag
MOV vrecflg,AL
POP varspc ; restore memory used
CALL csemi ; semicolon ?
JZ rcdvlp ; yes: another
rcde CMP.B vrecflg,#$00 ; variant record ?
JZ rcde1 ; :no
JMP ebrack2 ; '! )
rcde1 CALL ctoken ; END ?
W tkend
CALL errnz ; no:
B $0E ; 14:END expected
rcdret RET ; "
rectest CMP.B vrecflg,#$00 ; test end
JZ rectest2 ; :normal rec
JMP cbrack2 ; 'in variant rec: ) ?
rectest2CALL ctoken ; END ?
W tkend
RET ; "
set CALL ctoken ; SET ?
W tkset
JNZ setret ; no: ret
CALL expof ; ! OF
CALL rdscaltp ; get scalar type
MOV AX,upper ; upper bound
MOV BX,lower ; lower bound
MOV.B CL,AH ; one of them > 255 ?
OR.B CL,BH
CALL errnz ; yes:
B $46 ; 70:Set base type out of range
MOV CL,#$03 ; calculate component size
SHR AX,CL ; (upper/8)-(lower/8)+1
MOV CL,#$03
SHR BX,CL
SUB AX,BX
INC AX
MOV varsize,AX ; -> component size
MOV AX,vartp ; type ptr
MOV lower,AX ; -> type
MOV.B varctp,#$03 ; tag: set
CALL stotype ; store type
setret RET ; "
pointer CALL cptr ; pointer: prelim def
JNZ ptrret ; ptr ? no: ret
MOV AX,#$0000 ; tag: invisible
CALL symword ; store in symtab
PUSH symtop ; save pos
CALL rdsymnew ; get name of ptr
CALL symoffs ; write symtab offset
POP lower ; restore pos of prelim offset
MOV.B varctp,#$04 ; tag: pointer
MOV.B varnest,#$FF ; flag: not fully defined
MOV varsize,#$0004 ; size: 4 bytes
CALL stotype ; store type
ptrret RET ; "
file CALL ctoken ; FILE ?
W tkfile
JNZ fileret ; no: ret
CALL ctoken ; OF ?
W tkof
JNZ filuntp ; no: untyped file
CALL rdtype ; read type
CMP.B varctp,#$05 ; component type = file ?
JB file2 ; :no
CMP.B varctp,#$07
JA file2 ; :no
CALL err ; yes:
B $44 ; '68:File components may not be files
file2 MOV AX,vartp ; type ptr
MOV lower,AX ; store it
MOV.B varctp,#$05 ; typed file
MOV varsize,#$004C ; set size
CALL stotype ; store type
fileret RET ; '
filuntp MOV BP,ptcbeg ; untyped file
B $81,$ED,$02,$00 ; point to it
JMP stdtype ; "standard type
text CALL ctoken ; TEXT ?
W tktext
JNZ textret ; no:ret
CALL csqr1 ; [ ?
JNZ textstd ; no: standard text file
CALL rdintcn ; get integer constant
OR BX,BX ; buffer size = 0 ?
CALL errz ; yes:
B $2D ; 45:Constant out of range
CALL esqr2 ; ! ]
ADD BX,#$4C ; add size of file var
MOV varsize,BX ; -> var size
MOV.B varctp,#$06 ; text file
CALL stotype ; store type
textret RET ; '
textstd MOV BP,ptcbeg ; set ptr to std TEXT file
B $81,$ED,$3E,$00
JMP stdtype ; 'standard type
string CALL ctoken ; STRING ?
W tkstr
JNZ strrt ; no: ret
CALL esqr1 ; ! [
CALL rdintcn ; get integer constant
OR.B BH,BH ; > 255 ?
CALL errnz ; yes:
B $31 ; 49:Invalid string length
OR.B BL,BL ; length = 0 ?
CALL errz ; yes:
B $31 ; 49:Invalid string length
CALL esqr2 ; ! ]
INC BX ; len+1 (for length byte)
MOV varsize,BX ; -> component size
MOV.B varctp,#$08 ; tag: string
CALL stotype ; store type
strrt RET ; "
scalar CALL cbrack1 ; do scalar list
JNZ scalret ; ( ? no: ret
MOV BX,#$FFFF ; init counter
scallp PUSH BX
MOV AX,#$0200 ; tag: const
CALL symword ; store tag word
CALL rdsym ; read symbol
MOV AL,scalcnt ; number of scalar type
CALL symbyte ; store (elementary type)
POP AX ; restore counter
INC AX ; inc it
PUSH AX ; save it again
CALL symword ; store value of that const
CALL symoffs ; write symtab offset
CALL ccomma ; , ?
POP BX
JZ scallp ; yes: another element
CALL ebrack2 ; ! )
MOV.B CL,scalcnt ; number of this type
INC.B scalcnt ; count scalar types
XOR DX,DX ; clear lower bound
scalsto MOV.B varctp,CL ; store component type
MOV upper,BX ; store upper bound
MOV lower,DX ; store lower bound
OR.B DH,BH ; byte possible ?
MOV AX,#$0001 ; size = 1
JZ scalbyt ; yes: ok
INC AX ; size = 2
scalbyt MOV varsize,AX ; store component size
CALL stotype ; store type
scalret RET ; "
subrangeCALL rdconst ; do subrange: read constant
JNZ subret ; no good: ret
PUSH CX ; save type, result
PUSH BX
CMP.B CL,#$0A ; scalar ?
CALL errb ; no:
B $33 ; 51:Invalid subrange base type
CALL ctoken ; .. ?
W tk2dot
CALL errnz ; no:
B $0B ; 11: .. expected
CALL rdnumcn ; get constant
POP DX ; restore component type
POP AX ; restore lower bound
CMP.B CL,AL ; same component type ?
CALL errnz ; no:
B $2C ; 44:Type mismatch
CMP BX,DX ; upper >= lower ?
JGE scalsto ; yes: ok
CALL err ; 52:Lower bound > upper bound
B $34 ; '
subret RET ; "
rdscaltpCALL subrange ; get scalar type: do subrange
JZ rdscret ; done: ret
CALL scalar ; do scalar list
JZ rdscret ; done: ret
CALL srchtype ; search type
CALL errnz ; complex ?
B $1E ; 30:Simple type expected
CMP.B varctp,#$0A ; scalar ?
JNB rdscret ; :yes
CALL err ; 30:Simple type expected
B $1E ; '
rdscret RET ; "
progpartMOV.B stklev,#$00 ; Program part
MOV.B withnest,#$00 ; no with nesting
CALL block ; do block
PUSH pc ; save PC: jump to end of exit codes
CALL ejump ; emit jump
MOV BP,symtop2
prpatch CMP BP,symtop ; = actual symtab top ?
JZ prpend ; yes: end it
MOV BX,[BP]-$02 ; get dest addr
OR BX,BX ; exit ?
JZ prpexit ; :yes
SS:
MOV AX,[BX]-$02 ; get dest offset (from label)
SS:
MOV.B CH,[BX]-$04 ; label defined ?
CMP.B CH,#$FF ; no:
CALL errz ; 40:Undefined label
B $28
JMP.b prpgoto ; 'patch GOTO
prpexit POP AX ; get PC of end jump
PUSH AX ; = dest
MOV CH,#$00 ; level: 0
prpgoto MOV BX,[BP]-$04 ; get addr of jump
INC BX ; +1: point to offset
MOV.B CL,[BP]-$05 ; stack level-dest stack level
SUB.B CL,CH
JNZ prpremov ; not zero: remove from stack
CALL ptcjmp ; patch jump
JMP.b prpnxt ; '
prpremovCALL errb ; trying to jump into a WITH/FOR ?
B $47 ; 71:Invalid GOTO
PUSH AX ; save PC of end jump
CALL ptcjmppc ; patch jump to current pos
prpremlpCALL epopax ; * POP AX
DEC.B CL ; remove another var from stack ?
JNZ prpremlp ; :no
POP AX ; restore PC of end jump
CALL ejump ; emit jump to end jump
prpnxt SUB BP,#$05 ; go to next entry
JMP prpatch ; 'next one
prpend POP BX ; restore PC of end jump
INC BX ; point to offset
JMP ptcjmppc ; "patch jump
block CALL statemnt ; do block: do statement
CALL ctoken ; END ?
W tkend
JZ blkret ; yes: done
CALL esemi2 ; !
JMP block ; 'next statement
blkret RET ; "
statemntMOV.B semiflg,#$FF ; Do statement
MOV AX,direct ; get compiler directives
MOV direcsv,AX ; use copy during statement
TEST direcsv,#$0010 ; user interrupt ?
JZ stmnoint ; :no
MOV.B usrint,#$FF ; set flag: used
CALL ecode ; * INT 3
B $01,$CC
stmnointCALL ckey ; search keyword - code level
B $02
W tkbegin
JZ stmstd2 ; :found
CALL rdvar ; search var
JNZ stmproc ; :not found
JMP cassign ; 'do assignment
stmproc MOV CX,#$0500 ; search procedure
CALL search
JNZ stmlabel ; :not found
JMP cproc ; 'do procedure
stmlabelMOV CX,#$0100 ; search label
CALL search
JZ clabel ; :found
MOV CX,#$0600 ; search function
CALL search
JNZ stmstd ; :not found
JMP assgnvar ; 'do function: assign return var
stmstd CALL ckey ; search keyword: std procedures
B $02
W stdprocs
JZ stmstd2 ; :found
RET ; '
stmstd2 CS: ; jump to procedure compilation
JMP [BX] ; "routine
clabel CALL ecolon ; ! : - do label
MOV AL,lexnest ; lexical level
CMP.B AL,[BP]-$03 ; = that of label ?
CALL errnz ; no:
B $48 ; 72:Label not within current block
CMP.B [BP]-$04,#$FF ; label already defined ?
CALL errnz ; 43:Duplicate ID or label
B $2B
MOV AL,stklev ; store stack level
MOV.B [BP]-$04,AL ; in label entry
MOV AX,pc ; store offset
MOV [BP]-$02,AX
JMP statemnt ; "do statement
if CALL excond ; IF: evaluate condition
MOV AL,brnchop ; branch opcode
MOV AH,#$03 ; offset
CALL eword ; emit branch
PUSH pc ; save pos of jump
CALL ejump ; emit jump
CALL ctoken ; THEN ?
W tkthen
CALL errnz ; no:
B $11 ; 17:THEN expected
CALL statemnt ; do statement
CALL ctoken ; ELSE ?
W tkelse
JNZ ifnoelse ; :no
POP BX ; get pos of THEN-jump
PUSH pc ; save pos of second jump
CALL ejump ; emit second jump
INC BX ; point to offset
CALL ptcjmppc ; patch jump addr: to ELSE-part
CALL statemnt ; do statement
ifnoelsePOP BX ; restore pos
INC BX ; point to offset
JMP ptcjmppc ; "patch jump offset
while PUSH pc ; WHILE: save loop beg addr
CALL excond ; evaluate condition
MOV AL,brnchop ; branch opcode
MOV AH,#$03 ; offset
CALL eword ; emit branch
PUSH pc ; save pos of jump to end
CALL ejump ; emit it
CALL ctoken ; DO ? Bug: not checked
W tkdo ; (try it !!)
CALL statemnt ; do statement
POP BX ; pos of jump
POP AX ; pos of loop beg
CALL ejump ; emit jump to loop beg
INC BX ; point to offset
JMP ptcjmppc ; "patch jump to loop end
repeat PUSH pc ; REPEAT: save loop beg addr
reploop CALL statemnt ; do statement
CALL ctoken ; UNTIL ?
W tkuntil
JZ repend ; yes: end it
CALL esemi2 ; !
JMP reploop ; '
repend CALL excond ; evaluate condition
MOV AL,brnchop ; branch opcode
MOV AH,#$03 ; offset
CALL eword ; emit branch
POP AX ; restore pos: loop beg
JMP ejump ; "emit jump to loop beg
for MOV CX,#$0400 ; FOR
CALL search ; search loop var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
CALL getvprm ; get var parms
MOV.B indflg,#$00 ; not indexed
CMP.B indptflg,#$00 ; var indirect ?
JNZ forerr ; yes: error
CMP.B varctp,#$0A ; scalar ?
JNB forstrt ; :yes, ok
forerr CALL err ; 30:Simple type expected
B $1E ; '
forstrt CALL pushe1 ; push var entry
MOV AL,varctp ; save component type
PUSH AX
CALL eassign ; ! :=
CALL exprax ; expression -> AX
CALL epushax ; * PUSH AX
POP AX ; component type
PUSH AX
CMP.B AL,CL ; = type read ?
CALL errnz ; no:
B $2C ; 44:Type mismatch
CALL ckey ; TO or DOWNTO ?
B $04
W tkto
CALL errnz ; not found:
B $12 ; 18:TO or DOWNTO expected
MOV forptr,BX ; store direction pointer
CALL exprax ; expression -> AX
POP AX ; test component type
CMP.B AL,CL
CALL errnz ; 44:Type mismatch
B $2C
CALL ctoken ; DO ?
W tkdo
CALL errnz ; no:
B $0D ; 13:DO expected
CALL pope1 ; restore entry from stack
CALL ecode ; * POP CX
B $04,$59,$91,$2B,$C8 ; * XCHG CX,AX
MOV BX,forptr ; * SUB CX,AX
CS: ; get flag: pointer to table entry
MOV.B AL,[BX] ; get branch
CALL ebyte ; emit it
CALL ecode ; * branch offset
B $04,$03,$E9,$00,$00 ; * JUMP ....
PUSH pc ; save jump pos
CS:
MOV.B AL,[BX]$01 ; emit INC/DEC
CALL ebyte
CALL estore2 ; store var
PUSH pc ; save PC
CALL ecode ; * PUSH CX
B $01,$51
CALL pushe1 ; save var entry
PUSH forptr ; save for-ptr
INC.B stklev ; space used on stack (counter!)
CALL statemnt ; do statement
DEC.B stklev ; remove from stack
POP forptr ; restore FOR-ptr
CALL pope1 ; restore var entry
CALL ecode ; * POP CX
B $01,$59 ; (get counter var from stack)
MOV BX,forptr
CS:
MOV.B AL,[BX]$02 ; INC/DEC CX
CALL ebyte ; emit
PUSH pc ; save PC
CALL eword ; emit (dummy) branch to loop end
CS:
MOV.B DH,[BX]$03 ; INC or DEC var ?
MOV DL,#$FF ; word opcode
CMP varsize,#$01 ; test component size
JA forword ; :word
MOV DL,#$FE ; byte obcode
forword CALL einstr ; emit INC loop var
POP BX ; restore PC
POP AX ; restore PC: beg of loop
CALL ejump ; emit jump to loop beg
MOV AX,pc ; PC-dest-2
SUB AX,BX
DEC AX
DEC AX
MOV.B AH,AL ; -> offset
MOV AL,#$74 ; JZ
CALL ptcjmp2 ; patch branch: to loop end
POP BX ; restore addr: loop beg-2
DEC BX
DEC BX
JMP ptcjmppc ; "patch jump to loop end
case CALL exscal ; CASE: get scalar expression
MOV.B casectp,CL ; store CASE-type
CALL expof ; ! OF
XOR CX,CX ; clear counter: main
PUSH CX
caselp1 XOR CX,CX ; clear counter: sub
caselp2 PUSH CX ; save it
CALL cmpbound ; get element / lower bound
CALL ctoken ; .. ?
W tk2dot
MOV DL,#$74 ; JZ
JNZ casenrng ; :no
CALL ecode ; * JL +05
B $02,$7C,$05
CALL cmpbound ; get upper bound
MOV DL,#$7E ; JG
POP CX ; count: range done
INC.B CH ; count space used
PUSH CX
casenrngPOP CX ; restore counter
INC.B CH ; count space used
INC.B CL ; count labels
PUSH DX ; save opcode
PUSH pc ; save pos
CALL eword ; emit branch op
CALL ccomma ; , ?
JNZ caselab ; :no
CMP.B CH,#$14 ; branch distance ok ?
JB caselp2 ; :yes
CALL ecode ; * JMP +02
B $02,$EB,$02 ; make a hip
XOR.B CH,CH ; clear space used
casehip POP BX ; get branch pos
POP DX ; get opcode
MOV AX,pc ; PC-pos-2
SUB AX,BX
DEC AX
DEC AX
MOV.B AH,AL ; -> offset
MOV.B AL,DL ; branch opcode
CALL ptcjmp2 ; patch in branch
LOOP casehip ; :another one
MOV DL,#$EB ; JMP
PUSH DX ; remember opcode
PUSH pc ; & position
CALL eword ; emit it (dummy)
MOV CX,#$0101 ; space counter
JMP caselp2 ; 'continue
caselab CALL ecolon ; ! :
CALL ejump ; emit jump to next case label
XOR.B CH,CH ; clear space counter
caseres POP BX ; fill in branches - as above !
POP DX
MOV AX,pc
SUB AX,BX
DEC AX
DEC AX
MOV.B AH,AL
MOV.B AL,DL
CALL ptcjmp2 ; patch it
LOOP caseres ; :another
POP CX ; restore main counter
PUSH pc ; save current pos
INC CX ; count case labels
PUSH CX ; save again
MOV AL,casectp ; save type
PUSH AX ; (CASE may be nested !)
CALL statemnt ; do statement
POP AX ; restore type
MOV casectp,AL
CALL csemi ; semicolon ?
MOV DL,#$FF ; set flag
JZ casesemi ; :yes
XOR.B DL,DL ; clr flag
casesemiPUSH DX ; save it
CALL ctoken ; END ?
W tkend
POP DX ; restore flag
JZ caseres2 ; :yes
CALL ejump ; emit jump to end of CASE
POP CX ; counter
POP BX ; pos of last comparison
PUSH pc ; save pos of jump to CASE-end
PUSH CX ; save counter
DEC BX ; pos-2
DEC BX
CALL ptcjmppc ; patch jump
PUSH DX ; flag
CALL ctoken ; ELSE ?
W tkelse
POP DX ; 'flag
JZ caseelse ; :yes
OR.B DL,DL ; test flag
JZ caseend ; :no semicolon
JMP caselp1 ; 'case loop
caseend CMP.B semiflg,#$00 ; flag for semi error
CALL errz ; cleared:
B $0E ; 14:END expected
CALL err
B $29 ; "41:Unknown ID or syntax error
caseelseCALL statemnt ; ELSE-part: do statement
CALL ctoken ; END ?
W tkend
JZ caseres2 ; :yes
CALL esemi2 ; !
JMP caseelse ; '
caseres2POP CX ; number of jumps
caseres3POP BX ; addr of jump-2
DEC BX
DEC BX ; patch jumps to end of CASE
CALL ptcjmppc
LOOP caseres3 ; :another
RET ; "
cmpboundCALL rdnumcn ; get bound: read num constant
CMP.B CL,casectp ; correct type ?
CALL errnz ; 46:Constant and CASE selector type
B $2E ; does not match
MOV AL,#$3D ; * CMP AX,i
CALL ebyte
XCHG AX,BX ; emit constant: bound
JMP eword ; "
goto MOV CX,#$0100 ; do GOTO
CALL search ; search label
CALL errnz ; not found:
B $28 ; 40:Undefined label
MOV.B AL,[BP]-$03 ; lexical level
CMP.B AL,lexnest ; = current ?
CALL errnz ; no:
B $48 ; 72:Label not within current block
MOV AX,BP ; symtab-ptr of label
exit CALL symword ; store in symtab
MOV AX,pc ; store PC
CALL symword
MOV AL,stklev ; store stack level
CALL symbyte
JMP ejump ; "emit jump - resolved at block end
with MOV AL,withnest ; WITH: nesting level
MOV.B AH,stklev ; stack level
PUSH AX ; save them
withlp CMP.B withnest,#$10 ; too much ?
CALL errz ; yes:
B $61
CALL rdvar ; get var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
CMP.B varctp,#$02 ; type = record ?
CALL errnz ; no:
B $1D ; 29:Record variable expected
CMP.B indflg,#$00 ; indexed ?
JNZ withindx ; :yes
MOV.B AH,varseg ; segment and offset
MOV DX,varofs ; already known
JMP.b withsto ; 'store in WITH-buffer
withindxCALL varptr2 ; get var ptr
CALL epushdi ; * PUSH DI
ADD.B stklev,#$02 ; 4 bytes on stack
MOV.B AH,stklev ; get stack level
MOV DX,#$FFFF ; dummy pos: variable
withsto MOV.B BL,withnest
XOR.B BH,BH ; nesting level*4 -> BX
SHL BX,1 ; offset into WITH-buffer
SHL BX,1
MOV AL,varnest ; store type, position
MOV [BX]withtab,AX ; -> WITH-buffer
MOV [BX]withtab1,DX
INC.B withnest ; inc nesting level
CALL ccomma ; , ?
JZ withlp ; yes: repeat
CALL ctoken ; DO ?
W tkdo
CALL errnz ; no:
B $0D ; 13:DO expected
CALL statemnt ; do statement
MOV.B CL,stklev ; stack usage
POP AX ; restore stack usage, nesting level
MOV withnest,AL
MOV.B stklev,AH
SUB.B CL,AH ; remove from stack ?
JZ withret ; :nothing to remove
MOV AX,#$C483 ; * ADD SP,...
CALL eword
MOV.B AL,CL ; var count * 2
SHL.B AL,1
CALL ebyte ; emit byte
withret RET ; "
inline CALL ebrack1 ; ! ( - Inline
inllp MOV.B inlinflg,#$02 ; flag: byte mode
MOV AL,#$3E
CALL chkal ; > ?
JZ inltp ; :yes
MOV.B inlinflg,#$01 ; word mode
MOV AL,#$3C ; < ?
CALL chkal
JZ inltp ; :yes
MOV.B inlinflg,#$00 ; normal mode
inltp XOR BX,BX ; clear number
XOR CX,CX ; clear neg flag
inlexlp PUSH BX ; save
PUSH CX
CALL rdconst ; read num constant
JNZ inlnocn ; :no good
CMP.B CL,#$0A ; type = integer ?
CALL errnz ; no:
B $16 ; 22:Integer constant expected
XCHG AX,BX ; result -> AX
JMP.b inlatom ; '
inlnocn CMP.B inlinflg,#$00 ; normal mode ?
JNZ inlpc ; :no
MOV.B inlinflg,#$02 ; set word mode
inlpc MOV AL,#$2A ; * ?
CALL chkal
JNZ inlvar ; :no
MOV AX,pc ; PC -> result
JMP.b inlatom ; '
inlvar MOV CX,#$0400 ; search var
CALL search
JNZ inlproc ; :not found
CALL getvprm ; get var parms
MOV AX,varofs ; get var offset
JMP.b inlatom ; '
inlproc MOV CX,#$0500 ; search proc
CALL search
JZ inlproc2 ; :found
MOV CX,#$0600 ; search func
CALL search
CALL errnz ; not found:
B $4A ; 74:Inline error
inlproc2MOV AX,[BP]-$08 ; get offset
inlatom POP CX ; restore
POP BX
JCXZ inlnoneg ; :no negation
NEG AX ; negate result
inlnonegADD BX,AX ; add to number
XOR CX,CX ; clear neg flag
MOV AL,#$2B ; + ?
CALL chkal
JZ inlexlp ; :yes
DEC CX ; set neg flag
MOV AL,#$2D ; - ?
CALL chkal
JZ inlexlp ; :yes
XCHG AX,BX ; else: end of expression
CMP.B inlinflg,#$01 ; byte mode ?
JA inlword ; :word mode
JZ inlbyte ; :byte mode
OR.B AH,AH ; normal mode: result > 255 ?
JNZ inlword ; :yes
inlbyte CALL ebyte ; emit byte
JMP.b inlchk ; '
inlword CALL eword ; emit word
inlchk MOV AL,#$2F ; / ?
CALL chkal
JNZ inlend ; no: end it
JMP inllp ; 'loop back: next expression
inlend CALL ebrack2 ; ! )
RET ; "
cproc CALL estkchk ; procedure call: stack checking
cproc2 PUSH BP ; save symtab pos
MOV.B CL,[BP]-$10 ; parameter count
SUB BP,#$10 ; go to parameter
OR.B CL,CL ; any parms ?
JNZ cprparms ; :yes
JMP cprnoprm ; 'none - end it
cprparmsCALL ebrack1 ; ! (
cprlp1 PUSH CX ; parameter loop
PUSH BP ; save counter, symtab pos
MOV CX,[BP]-$04 ; parm count same type
MOV BP,[BP]-$02 ; type ptr
CALL getvprm2 ; get type parms
cprlp2 PUSH CX ; save counter
OR.B CH,CH ; VAR-parameter ?
JNZ cprvar ; :yes
CMP.B varctp,#$03 ; set ?
JB cprcpl ; :below, complex var
CALL exprsave ; get expression -> AX/stack
CALL typechk ; type checking, conversions
CALL erngchk ; range check
CMP.B varctp,#$0A ; scalar ?
JNB cprscal ; :yes
CMP.B varctp,#$04 ; ptr ?
JNZ cprstr ; :no
CALL ecode ; * PUSH DX
B $01,$52
cprscal CALL epushax ; * PUSH AX
JMP.b cprnext ; 'next parm
cprstr CMP.B varctp,#$08 ; string ?
JNZ cprset ; :no
MOV.B AH,varsize ; get max length
DEC.B AH
MOV AL,#$B1
CALL eword ; * MOV CL,max_len
MOV AX,#xstrparm ; adapt string size
CALL ecall ; * CALL xstrparm
JMP.b cprnext ; 'next parm
cprset CMP.B varctp,#$03 ; set ?
JNZ cprnext ; no:next parm
CALL esetfac ; calc set crunch factor
MOV AX,#xsetparm ; adapt set size
CALL ecall ; * CALL xsetparm
JMP.b cprnext ; 'next parm
cprcpl CALL pushe1 ; save var entry: complex var
CALL fullvar ; do full var
CALL errnz ; no good:
B $29 ; 41:Unknown ID or syntax error
CALL varptr2 ; get var ptr
MOV AX,varsize ; component size
CALL emovcxi ; * MOV CX,compo_size
MOV AX,#xblkparm ; copy complex var to stack
CALL ecall ; * CALL xblkparm
JMP.b cprchk ; 'check type
cprvar CALL pushe1 ; save entry - VAR-parameter
CALL varptr ; get var ptr
CALL epushdi ; * PUSH DI
cprchk CALL copye2 ; copy entry from stack
CMP.B var2ctp,#$00 ; type = 0 ?
JZ cpruntyp ; yes: untyped
CALL tchkstrc ; type checking struct vars
cpruntypCALL pope1 ; restore entry
cprnext POP CX ; restore counter
DEC.B CL ; another parm of same type ?
JZ cprskip ; :no
CALL ecomma ; ! ,
JMP cprlp2 ; 'loop back - same type
cprskip POP BP ; restore symtab pos
SUB BP,#$04 ; go to next parm
MOV.B AL,[BP]$00 ; get cnt
cprsklp DEC BP
MOV.B CL,[BP]$00 ; skip var entries
XOR.B CH,CH
SUB BP,CX ; skip name
DEC.B AL ; count down
JNZ cprsklp ; :another
POP CX ; restore count
DEC.B CL ; another parameter ?
JZ cprend ; :no
CALL ecomma ; ! ,
JMP cprlp1 ; 'loop back
cprend CALL ebrack2 ; ! )
cprnoprmPOP BP ; symtab pos
MOV AX,[BP]-$0E ; overlay ?
OR AX,AX
JZ cprnoovr ; :no
CALL emovaxi ; * MOV AX,proc_len
MOV AX,[BP]-$0C ; get file offset
CALL emovdxi ; * MOV DX,file_offs
cprnoovrMOV AX,[BP]-$08 ; get proc offset
JMP ecall ; "* CALL proc
estkchk TEST direcsv,#$0020 ; Stack checking ?
JZ estkret ; :switched off
MOV AX,[BP]-$0A ; get space needed
CALL emovcxi ; * MOV CX,space_needed
MOV AX,#xchkstk
CALL ecall ; * CALL xchkstk
estkret RET ; "
cassign CMP.B varctp,#$00 ; Do assignment: untyped ?
JZ asnerr ; yes: error
CMP.B varctp,#$05 ; file var ?
JB asnscal ; :no
CMP.B varctp,#$07
JA asnscal ; :no
asnerr CALL err ; files cannot be assigned !
B $36 ; '54:Illegal assignment
asnscal CMP.B varctp,#$0A ; scalar ?
JNB asnscal2 ; :yes
CMP.B varctp,#$04 ; pointer ?
JNZ asnvar ; :no
asnscal2CMP.B varseg,#$FD ; segment = ES ?
JNZ asnnoseg ; :no
MOV.B flgpshes,#$01 ; set flag: PUSH ES
asnnosegCMP.B indflg,#$00 ; indexed ?
JZ asn2 ; :no
MOV.B flgpshdi,#$01 ; set flag: PUSH DI
JMP.b asn2 ; '
asnvar CALL varptr2 ; get var ptr
CALL epushdi ; * PUSH DI
asn2 CALL eassign ; ! :=
CMP.B varctp,#$03 ; set ?
JB asncpl ; :no, complex type
CALL pushe1 ; save dest var entry
PUSH pc ; save PC
CALL expr ; evaluate expression
POP AX ; old = new PC ?
SUB AX,pc
MOV flgpshes,#$0000 ; clear flag: PUSH ES
PUSH AX ; save difference
CALL expload ; get expression, ready for store
POP AX
CALL pope1 ; restore dest var entry
PUSH AX ; save diff
CALL typechk ; type checking, conversions
POP AX
CMP.B varctp,#$0A ; scalar ?
JNB asnscal3 ; :yes
CMP.B varctp,#$04 ; pointer ?
JNZ asnstore ; :no
asnscal3OR AX,AX ; test diff
JZ asnstore ; none: ok
CMP.B indflg,#$00 ; indexed ?
JZ asnnoind ; :no
CALL ecode ; * POP DI - restore ptr
B $01,$5F
asnnoindCMP.B varseg,#$FD ; segment = ES ?
JNZ asnstore ; :no
CALL ecode ; * POP ES
B $01,$07
asnstoreJMP estore ; 'Store var
asncpl CALL pushe1 ; store dest var entry
CALL fullvar ; do full var
CALL errnz ; no good:
B $29 ; 41:Unknown ID or syntax error
CALL varptr2 ; get var ptr
CALL pope2 ; restore dest var entry
CALL tchkstrc ; type checking - struct vars
MOV AX,var2size ; component size
CALL emovcxi ; * MOV CX,comp_size
MOV AX,#xmovevar
JMP ecall ; '* CALL xmovevar
typechk CMP.B varctp,#$09 ; Type checking, conversions
JNZ tckstr ; :no real
CMP.B CL,#$0A ; now integer ?
JNZ tckchk ; :no
MOV AX,#xintreal ; conversion int -> real
CALL ecall ; * CALL xintreal
MOV CL,#$09 ; now real
JMP.b tckchk ; '
tckstr CMP.B varctp,#$08 ; string expected ?
JNZ tckch ; :no
CMP.B CL,#$0C ; result = char ?
JNZ tckchk ; :no
CALL ecode ; * MOV AH,AL
B $05,$8A,$E0,$B0,$01,$50 ; * MOV AL,01
MOV CL,#$08 ; * PUSH AX
JMP.b tckchk ; 'now string
tckch CMP.B varctp,#$0C ; char expected ?
JNZ tckchk ; :no
CMP.B CL,#$08 ; result = string ?
JNZ tckchk ; :no
MOV AX,#xstrch ; convert to char
CALL ecall ; * CALL xstrch
MOV CL,#$0C ; now char
tckchk CMP.B CL,varctp ; type = expected ?
JNZ tckerr ; no: error
CMP.B CL,#$03 ; set ?
JNZ tckptr ; :no
OR.B CH,CH ; constant ?
JZ tckret ; yes: ret
MOV BP,lower ; same base type ?
CMP.B CH,[BP]-$08
JZ tckret ; yes: ret
tckerr CALL err ; 44:Type mismatch
B $2C ; '
tckptr CMP.B CL,#$04 ; pointer ?
JNZ tckret ; no: ret
MOV AX,functp ; type pointer
OR AX,AX ; untyped ?
JZ tckret ; yes: ret
CMP AX,lower ; compare types
JNZ tckerr ; different: error
tckret RET ; "
tchkstrcMOV AL,varctp ; Type checking struct vars
CMP AL,#$00 ; type expected: untyped ?
JZ tcserr ; yes: type mismatch
MOV DL,#$BF ; check everything
CMP AL,#$0A ; scalar ?
JNB tcschk ; yes: check it
CMP AL,#$08 ; string ?
JNZ tcsnostr ; :no
MOV DL,#$80 ; check type only
TEST direcsv,#$0040 ; string checking ?
JZ tcschk ; :no
tcsnostrMOV DL,#$83 ; check type, component size
CMP AL,#$06 ; text, untyped file ?
JNB tcschk ; :check it
MOV DL,#$B3
CMP AL,#$03 ; set ?
JNB tcschk ; :check it
MOV DL,#$C3 ; check type, rec nest, size
CMP AL,#$02 ; record ?
JNB tcschk ; :check it
CMP upper,#$00 ; second type
MOV DL,#$BF ; check everything
JNZ tcschk ; :check it
MOV BP,upper2 ; second type
CMP.B [BP]-$08,#$0A ; scalar index ?
JNZ tcserr ; no: type mismatch
MOV DL,#$B3 ; check type, lower, upper, size
tcschk MOV SI,#varctp ; check buffers
MOV DI,#var2ctp
MOV CX,#$0008 ; check 8 bytes
tcschklpROL.B DL,1 ; test this byte ?
JNB tcsnochk ; :no
MOV.B AL,[SI] ; compare
CMP.B AL,[DI]
JNZ tcserr ; different: error
tcsnochkINC SI ; next byte
INC DI
LOOP tcschklp ; :another
RET ; '
tcserr CALL err ; 44:Type mismatch
B $2C ; "
assgnvarCALL getvprm ; get var parms
CMP.B indptflg,#$00 ; indirect ?
CALL errnz ; yes:
B $29 ; 41:Unknown ID or syntax error
CALL rdvarind ; do indexing
JMP cassign ; "do assignment
passign CALL brfilvar ; ASSIGN: get file var
MOV AX,#xassign ; normal Assign
CMP.B CL,#$06 ; text file ?
JNZ pasgn2 ; :no
MOV AX,#xassgntx ; assign text file
CALL pasgn2 ; get params
JMP.b pfilchk ; 'do checking
pasgn2 PUSH AX ; save call addr
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL exstr ; get string expr
POP AX ; restore call addr
pemit PUSH AX ; save call addr
CALL ebrack2 ; ! )
POP AX ; call addr
JMP ecall ; "emit call
prename CALL brfilvar ; RENAME: get file var
MOV AX,#xrename
CALL pasgn2 ; get string, emit call
JMP.b pfilchk ; "do checking
perase CALL brfilvar ; ERASE: get file var
MOV AX,#xerase
JMP.b pfilend ; 'put it
pchain MOV AX,#xchain ; CHAIN
JMP.b pexec2 ; 'put it
pexecuteMOV AX,#xexecute ; EXECUTE
pexec2 PUSH AX ; save addr
CALL brfilvar ; get file var
pexec3 POP AX ; restore addr
pfilend CALL pemit ; test ), emit call
pfilchk JMP efilchk ; "do checking
pseek CALL brfilvar ; SEEK, LONGSEEK: get file var
CMP.B CL,#$06 ; text file ?
CALL errz ; yes:
B $3F ; 63:Textfiles are not allowed here
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL exnum ; get num expr
MOV AX,#xseek
CMP.B CL,#$0A ; integer ?
JZ pseekint ; :yes
MOV AX,#xlngseek ; real...
pseekintJMP pfilend ; "test ), emit call, check
pappend CALL brfilvar ; APPEND: get file var
CMP.B CL,#$06 ; text file ?
CALL errnz ; no:
B $23 ; 35:Textfile expected
MOV AX,varsize ; component size
SUB AX,#$004C ; sub size of file var
CALL emovcxi ; * MOV CX,buf_size
MOV AX,#xappndtx
JMP pfilend ; "test ), emit call, check
preset MOV BX,#vreset ; RESET
JMP.b prw2 ; 'ptr into vector table
prewriteMOV BX,#vrewrite ; REWRITE
prw2 PUSH BX ; save ptr
CALL brfilvar ; get file var
CMP.B varctp,#$05 ; typed file ?
JNZ prwtext ; :no
MOV BP,lower ; type ptr
CALL getparm ; get var parms
MOV AX,var2size ; component size
CALL emovcxi ; * MOV CX,compo_size
JMP.b prwemit ; '
prwtext CMP.B varctp,#$06 ; text file ?
JNZ prwuntp ; :no
MOV AX,varsize ; var size-base size
SUB AX,#$004C
CALL emovcxi ; * MOV CX,buf_size
JMP.b prwemit ; '
prwuntp CALL epushdi ; * PUSH DI - untyped file
CALL ccomma ; , ?
JNZ prwuntp2 ; :no
CALL pushe1 ; save var entry
CALL exint ; get int expr: block size
CALL pope1 ; restore var entry
JMP.b prwemit ; '
prwuntp2MOV AX,#$0080 ; std blk size
CALL emovaxi ; * MOV AX,0080
prwemit POP BX ; restore table index
JMP.b pclose3 ; '
ptruncatMOV BX,#vtruncat ; TRUNCATE
JMP.b pclose2 ; '
pflush MOV BX,#vflush ; FLUSH
JMP.b pclose2 ; '
pclose MOV BX,#vclose ; CLOSE
pclose2 PUSH BX ; save table index
CALL brfilvar ; get file var
POP BX ; restore index
pclose3 CALL ebrack2 ; ! )
CALL ecallio ; emit call
JMP pfilchk ; "do checking
ecallio MOV AL,varctp ; emit call for I/O
SUB AL,#$05 ; (component type-5)*2
XOR.B AH,AH
ADD AX,AX
ADD BX,AX ; + BX -> pointer
CS:
MOV AX,[BX] ; get vector
JMP ecall ; "emit call
vreset W xresetty,xresettx,xreset ; vector table for I/O
vrewriteW xrewrtty,xrewrttx,xrewrtun
vclose W xclosety,xclosetx,xclosety
vflush W xflushty,xflush,xflushty
vtruncatW xtruncat,xtrunctx,xtrunc ; "
brfilvarCALL ebrack1 ; ! (
CALL rdfilvar ; get file var
JZ brfilret ; ok:ret
CALL err
B $15 ; '21:File variable expected
brfilretRET ; "
rdfilvarCALL rdvar ; get file var: get var
JZ rdfil2 ; :found
STC ; not found
RET ; '
rdfil2 CMP.B varctp,#$05 ; file var ?
JB rdfilnf ; :no
CMP.B varctp,#$07
JA rdfilnf ; :no
CALL varptr2 ; get var ptr
MOV.B CL,varctp ; get type
XOR AX,AX ; ok
rdfilnf CLC
RET ; "
preadln MOV AL,#$FF ; READLN: set flag
JMP.b prd1 ; '
pread XOR.B AL,AL ; READ
prd1 MOV rdlnflg,AL ; store flag
CALL cbrack1 ; ( ?
JZ prdfil ; :yes
CALL setinp ; set input path
JMP prdrdln ; 'do checking
prdfil CALL rdfilvar ; get file var
JB prderr ; :error
JNZ prdsetin ; no file var: use std
CMP.B CL,#$05 ; typed file ?
JNZ prdtext ; :no
JMP prdtyped ; 'do read typed file
prdtext CMP.B CL,#$06 ; text file ?
CALL errnz ; no:
B $41 ; 65:Untyped files are not allowed here
MOV AX,#xrdfil ; (prepare for input)
CALL ecall ; * CALL xrdfil
JMP prdnxt ; '
prderr CALL err ; 41:Unknown ID or syntax error
B $29 ; '
prdsetinCALL setinp ; set input path
JMP.b prdlp2 ; '
prdloop CALL rdvar ; parameter loop: read var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
prdlp2 CALL varptr2 ; get var ptr
MOV.B CL,varctp ; component type
CMP.B CL,#$01 ; array ?
JZ prdarrch ; yes: read as byte block
CMP.B CL,#$08 ; file, ptr, set, record ?
JB prderrtp ; :not allowed
CMP.B CL,#$0B ; boolean ?
JZ prderrtp ; :not allowed
CMP.B CL,#$0D ; scalar ?
JB prdstr ; below: ok
prderrtpCALL err ; 66:I/O not allowed here
B $42 ; '
prdarrchMOV BP,lower ; type ptr - test array of char
CMP.B [BP]-$08,#$0C ; component type = char ?
JNZ prderrtp ; no:error
MOV BP,upper ; index type = integer ?
CMP.B [BP]-$08,#$0A
JNZ prderrtp ; no:error
MOV AX,varsize ; component size
OR.B AH,AH ; > 255 ?
JNZ prderrtp ; yes:error
MOV.B AH,AL ; * MOV CL,len
MOV AL,#$B1
CALL eword
MOV AX,#xrdarrch ; (read array of char)
JMP.b prdemit ; '
prdstr CMP.B CL,#$08 ; string ?
JNZ prdnum ; :no
MOV.B AH,varsize ; max len-1
DEC.B AH
MOV AL,#$B1
CALL eword ; * MOV CL,max_len
MOV AX,#xrdstr ; (read string)
JMP.b prdemit ; '
prdnum MOV AX,#xrdreal ; (read real)
CMP.B CL,#$09 ; real ?
JZ prdemit ; :yes
MOV AX,#xrdchar ; (read char)
CMP.B CL,#$0C ; char ?
JZ prdemit ; :yes
MOV AX,#xrdint ; (read integer)
CMP varsize,#$01 ; word ?
JA prdemit ; :yes
MOV AX,#xrdbyte ; (read byte)
prdemit CALL ecall ; emit call
prdnxt CALL ccomma ; another var ?
JNZ prdend ; no: end it
JMP prdloop ; 'parameter loop
prdend CALL ebrack2 ; ! )
prdrdln MOV AX,#xreadln ; (readln)
prdln CMP.B rdlnflg,#$00 ; ReadLn ?
JZ efilchk ; :no
CALL ecall ; emit call
efilchk TEST direcsv,#$0001 ; do I/O-checking ?
JZ prdret ; :no
MOV AX,#xiochk ; (I/O-check)
CALL ecall
prdret RET ; "
setinp MOV AX,#xstdin ; set input path: std input
CMP cinpsize,#$00 ; buffer > 0 ?
JNZ setinprt ; yes: do it
TEST direcsv,#$0004 ; test I/O-mode
JZ setinprt ; :MS-DOS std input
MOV AX,#xrdln ; (read with editing)
CMP.B rdlnflg,#$00 ; ReadLn ?
JZ setinprt ; :no
MOV.B rdlnflg,#$00 ; clear flag
MOV AX,#xrd ; (Readln with editing)
setinprtJMP ecall ; "emit call
pwritelnMOV AL,#$FF ; WRITELN
JMP.b pwr1 ; '
pwrite XOR.B AL,AL ; WRITE
pwr1 MOV rdlnflg,AL ; set flag
CALL cbrack1 ; ( ?
JZ pwrfil ; yes: ok
MOV AX,#xstdout ; set std output
CALL ecall ; emit call
JMP pwrend2 ; 'end it
pwrfil CALL rdfilvar ; get file var
JB pwrstd2 ; :none
JNZ pwrstd ; no file var
CMP.B CL,#$05 ; typed file ?
JNZ pwrtext ; :no
JMP pwrtyped ; 'write typed file
pwrtext CMP.B CL,#$06 ; text file ?
CALL errnz ; no:
B $41 ; 65:Untyped files are not allowed here
MOV AX,#xwrfil ; (prepare for write)
CALL ecall ; * CALL xwrfil
JMP pwrnext ; '
pwrstd MOV AX,#xstdout ; set std output
CALL ecall ; * CALL xstdout
CALL expvar ; expression (var pre-read)
JMP.b pwrstr ; 'check type
pwrstd2 MOV AX,#xstdout ; set std output
CALL ecall ; * CALL xstdout
pwrloop CALL constel ; get const element
JNZ pwrexpv ; :no, try expression
CMP.B CL,#$08 ; string ?
JNZ pwrexpc ; :no
MOV DI,chptr ; check current char
CMP.B [DI],#$2C ; , ?
JZ pwrinlin ; :yes
CMP.B [DI],#$29 ; ) ?
JNZ pwrexpc ; no: normal
pwrinlinMOV AX,#xwrtinl ; (write inline string)
CALL ecall ; * CALL xwrtinl
CALL estring ; emit string
JMP.b pwrnext ; 'get next element
NOP
pwrexpc CALL expconst ; expression (const pre-read)
JMP.b pwrstr ; 'check type
pwrexpv CALL exprax ; expression (var pre-read)
pwrstr CMP.B CL,#$08 ; string ?
JB pwrerrtp ; below:illegal
CMP.B CL,#$0D ; scalar ?
JB pwrint ; below: ok
pwrerrtpCALL err ; 66:I/O not allowed here
B $42 ; '
pwrint CMP.B CL,#$0A ; integer ?
JB pwrnoint ; below: real, string
CALL epushax ; * PUSH AX - stack it
pwrnointCALL ccolon ; : ?
JNZ pwrdef ; no:default format
PUSH CX ; save type
CALL exint ; get int expression
POP CX
CMP.B CL,#$09 ; real ?
JNZ pwrchk ; no: no second parm
CALL ccolon ; : ?
JNZ pwrdef3 ; no: use default
CALL epushax ; * PUSH AX
PUSH CX ; save type
CALL exint ; get int expression
POP CX
JMP.b pwrchk ; 'continue
pwrdef XOR AX,AX ; standard format
CMP.B CL,#$09 ; real ?
JNZ pwrdef2 ; :no
MOV AL,#$12 ; default: 18 chars
pwrdef2 CALL emovaxi ; * MOV AX,field_len
CMP.B CL,#$09 ; real ?
JNZ pwrchk ; :no
pwrdef3 CALL epushax ; * PUSH AX
MOV AX,#$FFFF
CALL emovaxi ; * MOV AX,#FFFF
pwrchk MOV AX,#xwrtstr ; (write string)
CMP.B CL,#$08 ; string ?
JZ pwremit ; :yes
MOV AX,#xwrreal ; (write real)
CMP.B CL,#$09 ; real ?
JZ pwremit ; :yes
MOV AX,#xwrint ; (write integer)
CMP.B CL,#$0A ; integer ?
JZ pwremit ; :yes
MOV AX,#xwrbool ; (write boolean)
CMP.B CL,#$0B ; boolean ?
JZ pwremit ; :yes
MOV AX,#xwrchar ; (write char)
pwremit CALL ecall ; emit call
pwrnext CALL ccomma ; , ?
JNZ pwrend ; no: end it
JMP pwrloop ; 'do param loop
pwrend CALL ebrack2 ; ! )
pwrend2 MOV AX,#xwrln ; (writeln)
JMP prdln ; "like read/readln
prdtypedMOV AX,#xrdvar ; Read typed file
JMP.b pwt2 ; '(read byte block)
pwrtypedMOV AX,#xwrvar ; Write typed file
pwt2 CMP.B rdlnflg,#$00 ; ReadLn/WriteLn ?
CALL errnz ; yes:
B $23 ; 35:Textfile expected
PUSH AX ; save addr
MOV AX,#xfilsel ; (select file)
CALL ecall ; * CALL xfilsel
MOV BP,lower ; type ptr
CALL getparm ; get type parms
pwtloop CALL ccomma ; , ?
JNZ pwtend ; no: end it
CALL pushe2 ; push entry
CALL varptr ; get var ptr
CALL pope2 ; pop entry
CALL tchkstrc ; check type struct vars
POP AX ; get routine addr
PUSH AX
CALL ecall ; * CALL xwrvar / xrdvar
JMP pwtloop ; 'parameter loop
pwtend POP AX ; remove
CALL ebrack2 ; ! )
JMP efilchk ; "do checking
pblockrdMOV AX,#xblkrdrd ; BLOCKREAD
MOV BX,#xblkrd ; with / without res var
JMP.b pbl1 ; '
pblockwrMOV AX,#xblkwrrs ; BLOCKWRITE
MOV BX,#xblkwr
pbl1 PUSH AX ; save addr
PUSH BX
CALL brfilvar ; get file var
CMP.B CL,#$07 ; untyped ?
CALL errnz ; no:
B $25 ; 37:Untyped file expected
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL varptr ; get var ptr (src/dst var)
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL exint ; get int expr (count)
CALL ccomma ; , ?
POP BX ; restore addr
POP AX
JZ pblres ; yes: with result var
PUSH BX ; without result var
JMP.b pblend ; '
pblres PUSH AX ; save routine addr
CALL epushax ; * PUSH AX (save count)
CALL varptr ; get res var ptr
CMP.B varctp,#$0A ; integer ?
JNZ pblerr ; no: error
CMP varsize,#$02 ; word ?
JZ pblend ; yes: ok
pblerr CALL err ; 24:Integer variable expected
B $18 ; '
pblend JMP pexec3 ; "emit call, check end
pchdir MOV AX,#xchdir ; CHDIR
JMP.b prmd2 ; '
pmkdir MOV AX,#xmkdir ; MKDIR
JMP.b prmd2 ; '
prmdir MOV AX,#xrmdir ; RMDIR
prmd2 PUSH AX ; save addr
CALL ebrack1 ; ! (
CALL exstr ; get string expr
JMP pexec3 ; "complete it
pgetdir CALL ebrack1 ; ! ( : GETDIR
CALL exint ; get int expr
CALL epushax ; * PUSH AX
CALL ecomma ; ! ,
CALL rdstrvar ; get string var
MOV.B AH,varsize ; max len-1
DEC.B AH
MOV AL,#$B1
CALL eword ; * MOV CL,max_len
MOV AX,#xgetdir
JMP pemit ; "end it
povrpathCALL ebrack1 ; ! ( : OVRPATH
CALL exstr ; get string expr
MOV AX,#xovrpath
JMP pemit ; "end it
pdelete CALL ebrack1 ; ! ( : DELETE
CALL rdstrvar ; get string var
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL exint ; get int expr
CALL epushax ; * PUSH AX
CALL ecomma ; ! ,
CALL exint ; get int expr
MOV AX,#xdelete
JMP pemit ; "end it
pinsert CALL ebrack1 ; ! ( : INSERT
CALL exstr ; get string expr
CALL ecomma ; ! ,
CALL rdstrvar ; get string var
CALL epushdi ; * PUSH DI
MOV.B AH,varsize ; component size - 1
DEC.B AH
MOV AL,#$B1
PUSH AX ; save it
CALL ecomma ; ! ,
CALL exint ; get integer expr
POP AX ; restore
CALL eword ; * MOV CL,max_len
MOV AX,#xinsert
JMP pemit ; "end it
rdstrvarCALL varptr ; get string var: get var ptr
CMP.B varctp,#$08 ; string ?
CALL errnz ; no:
B $22 ; 34:String variable expected
RET ; "
pstr CALL ebrack1 ; ! ( : STR
CALL exnum ; get num expr
CMP.B CL,#$0A ; integer ?
JNZ pstnoint ; real: is already on stack !
CALL epushax ; * PUSH AX
pstnointCALL ccolon ; : ?
JNZ pstdef1 ; :no formatting
PUSH CX ; save type
CALL exint ; get int expr
CALL epushax ; * PUSH AX
POP CX ; restore type
CMP.B CL,#$0A ; integer ?
JZ pstnxt ; yes: no second parm
CALL ccolon ; : ?
JNZ pstdef3 ; no: get default
PUSH CX ; save type
CALL exint ; get int expr
CALL epushax ; * PUSH AX
POP CX ; restore type
JMP.b pstnxt ; '
pstdef1 XOR AX,AX ; set default
CMP.B CL,#$0A ; integer ?
JZ pstdef2 ; :yes
MOV AL,#$12 ; real: 18 chars
pstdef2 CALL emovaxi ; * MOV AX,i
CALL epushax ; * PUSH AX
CMP.B CL,#$0A ; integer ?
JZ pstnxt ; :yes
pstdef3 MOV AX,#$FFFF ; default for second parm:
CALL emovaxi ; * MOV AX,#FFFF
CALL epushax ; * PUSH AX
pstnxt CALL ecomma ; ! ,
PUSH CX ; save type
CALL rdstrvar ; get string var
MOV.B AH,varsize ; component size-1
DEC.B AH
MOV AL,#$B1
CALL eword ; * MOV CL,max_len
POP CX ; restore type
MOV AX,#xstrint ; (str integer)
CMP.B CL,#$0A ; integer ?
JZ pstemit ; :yes
MOV AX,#xstrreal ; (str real)
pstemit JMP pemit ; "emit call, check )
pval CALL ebrack1 ; ! ( : VAL
CALL exstr ; get string expression
CALL ecomma ; ! ,
CALL varptr ; get dest var ptr
MOV.B CL,varctp ; test type
CMP.B CL,#$0A ; integer ?
JZ pvalint ; :yes
CMP.B CL,#$09 ; real
JZ pvalreal ; :yes
CALL err ; 27:Integer or real var expected
B $1B ; '
pvalint CMP varsize,#$02 ; test component size
JNZ pvalerr ; byte: error
pvalrealPUSH CX ; save type
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL varptr ; get status var ptr
CMP.B varctp,#$0A ; integer ?
JNZ pvalerr ; no: error
CMP varsize,#$02 ; byte ?
JZ pvalok ; word:ok
pvalerr CALL err ; 24:Int var expected
B $18 ; '
pvalok POP CX ; restore type
MOV AX,#xvalint ; (val integer)
CMP.B CL,#$0A ; integer ?
JZ pstemit ; :yes
MOV AX,#xvalreal ; (val real)
JMP pstemit ; "emit call, check )
pgotoxy CALL ebrack1 ; ! ( : GOTOXY
CALL exint ; get integer expr
CALL epushax ; * PUSH AX
MOV AX,#xgotoxy
pgxy2 PUSH AX ; save addr
CALL ecomma ; ! ,
CALL exint ; get integer expr
POP AX ; restore addr
JMP pemit ; "emit call, check )
prndmizeMOV AX,#xrndmize ; RANDOMIZE
JMP ecall ; "emit call
pnew MOV AX,#xnew ; NEW
pnew2 PUSH AX ; save addr
CALL ebrack1 ; ! (
CALL varptr ; get var ptr
CMP.B varctp,#$04 ; pointer var ?
JNZ prelerr ; no: error
MOV BP,lower ; get type ptr
CALL getparm ; get type parms
MOV AX,var2size ; get its component size
CALL emovcxi ; * MOV CX,compo_size
POP AX ; restore addr
JMP pemit ; "emit call, check )
pgetmem MOV AX,#xgetmem ; GETMEM
pgm2 PUSH AX ; save addr
CALL ebrack1 ; ! (
CALL varptr ; get var ptr
CMP.B varctp,#$04 ; pointer ?
JNZ prelerr ; no: error
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL exint ; get int expr
POP AX ; restore addr
JMP pemit ; "emit call, check )
pdisposeMOV AX,#xdispose ; DISPOSE
JMP pnew2 ; "like New
pfreememMOV AX,#xfreemem ; FREEMEM
JMP pgm2 ; "like Getmem
pmark MOV AX,#xmark ; MARK
JMP.b prel2 ; 'like Release
preleaseMOV AX,#xrelease ; RELEASE
prel2 PUSH AX ; save addr
CALL ebrack1 ; ! (
CALL varptr ; get var ptr
POP AX ; restore addr
CMP.B varctp,#$04 ; pointer ?
JNZ prelerr ; no: error
JMP pemit ; 'emit call, check )
prelerr CALL err ; 28:Pointer var expected
B $1C ; "
pmove CALL ebrack1 ; ! ( : MOVE
CALL varptr ; get src var ptr
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL varptr ; get dest var ptr
CALL epushdi ; * PUSH DI
MOV AX,#xmove
JMP pgxy2 ; "get int expr, end it
pfillchrCALL ebrack1 ; ! ( : FILLCHAR
CALL varptr ; get dest var ptr
CALL epushdi ; * PUSH DI
CALL ecomma ; ! ,
CALL exint ; get int expr
CALL epushax ; * PUSH AX
CALL ecomma ; ! ,
CALL exscal ; get scalar expr
MOV AX,#xfillchr
JMP pemit ; "end it
pexit XOR AX,AX ; EXIT: clear flag
JMP exit ; "do it
phalt CALL cbrack1 ; HALT: ( ?
JNZ phlt2 ; no: normal
CALL exint ; get int expr
CALL ebrack2 ; ! )
JMP.b phlt3 ; '
phlt2 CALL ecode ; * XOR AX,AX
B $02,$33,$C0
phlt3 MOV AX,#progend
JMP ejump ; "emit jump
pmsdos CALL ebrack1 ; ! ( : MSDOS
MOV BX,#$0021 ; int number 21
PUSH BX ; save it
JMP.b pint2 ; 'like INTR
pintr CALL ebrack1 ; ! ( : INTR
CALL rdintcn ; read integer constant
PUSH BX ; save it
CALL ecomma ; ! ,
pint2 CALL varptr ; get var ptr
MOV AX,#xsetregs ; (set registers from rec)
CALL ecall ; * CALL xsetregs
POP AX ; interrupt number
MOV.B AH,AL
MOV AL,#$CD ; * INT nn
CALL eword
MOV AX,#xgetregs ; (get registers back)
JMP pemit ; "emit call, check )
pportw MOV AL,#$EF ; PORTW: opcode OUT
JMP.b pprt2 ; '
pport MOV AL,#$EE ; PORT: opcode OUTB
pprt2 PUSH AX ; save opcode
CALL esqr1 ; ! [
CALL exint ; get int expr
CALL esqr2 ; ! ]
CALL epushax ; * PUSH AX (port number)
CALL eassign ; ! :=
CALL exint ; get int expr
CALL ecode ; * POP DX
B $01,$5A
POP AX ; restore opcode
JMP ebyte ; "emit OUT [DX],AX
pcrtinitMOV AX,#xcrtinit ; CRTINIT
JMP.b pdelemit ; '
pcrtexitMOV AX,#xcrtexit ; CRTEXIT
JMP.b pdelemit ; '
pclrscr MOV AX,#xclrscr ; CLRSCR
JMP.b pdelemit ; '
pclreol MOV AX,#xclreol ; CLREOL
JMP.b pdelemit ; '
pnrmvid MOV AX,#xnormvid ; NORMVIDEO, HIGHVIDEO
JMP.b pdelemit ; '
plowvid MOV AX,#xlowvid ; LOWVIDEO
JMP.b pdelemit ; '
pinslineMOV AX,#xinsline ; INSLINE
JMP.b pdelemit ; '
pdellineMOV AX,#xdelline ; DELLINE
pdelemitJMP ecall ; "emit call
pdelay MOV AX,#xdelay ; DELAY
pdel2 PUSH AX ; save addr
CALL ebrack1 ; ! (
CALL exint ; get int expr
POP AX ; restore addr
JMP pemit ; "emit, check )
pwindow MOV AX,#xwindow ; WINDOW
pwind4 PUSH AX ; save addr
CALL ebrack1 ; ! (
pwind3 CALL exint ; get int expr
CALL epushax ; * PUSH AX
CALL ecomma ; ! ,
pwind2 CALL exint ; get int expr
CALL epushax ; * PUSH AX
CALL ecomma ; ! ,
CALL exint ; get int expr
CALL epushax ; * PUSH AX
POP AX ; restore addr
JMP pgxy2 ; "get int, end it
ptextcolMOV AX,#xtxtcol ; TEXTCOLOR
JMP pdel2 ; "(int)
ptextbg MOV AX,#xtxtbg ; TEXTBACKGROUND
JMP pdel2 ; "(int)
pgraphbgMOV AX,#xgrbg ; GRAPHBACKGROUND
JMP pdel2 ; "(int)
ppaletteMOV AX,#xpalette ; PALETTE
JMP pdel2 ; "(int)
phirscolMOV AX,#xhirscol ; HIRESCOLOR
JMP pdel2 ; "(int)
pgrcolmdMOV AX,#xgrcolmd ; GRAPHCOLORMODE
pgremit JMP ecall ; 'emit call
pgrmode MOV AX,#xgrmode ; GRAPHMODE
JMP pgremit ; 'emit call
phires MOV AX,#xhires ; HIRES
JMP pgremit ; "emit call
ptxtmodeCALL cbrack1 ; TEXTMODE
JZ ptxtmd2 ; ( ? yes: get mode
MOV AX,#$00FF
CALL emovaxi ; * MOV AX,#00FF
JMP.b ptxtdef ; '
ptxtmd2 CALL exint ; get int expr
CALL ebrack2 ; ! )
ptxtdef MOV AX,#xtxtmode
JMP ecall ; "emit call
pgrwind MOV AX,#xgrwindw ; GRAPHWINDOW
JMP pwind4 ; "like window
pplot CALL ebrack1 ; ! ( : PLOT
MOV AX,#xplot
PUSH AX ; save it
JMP pwind2 ; "like window - only 3 parms
pdraw CALL ebrack1 ; ! ( : DRAW
CALL exint ; get int expr
CALL epushax ; * PUSH AX
CALL ecomma ; ! ,
MOV AX,#xdraw
PUSH AX ; save addr
JMP pwind3 ; "now like window
psound MOV AX,#xsound ; SOUND
JMP pdel2 ; "(int)
pnosoundMOV AX,#xnosound ; NOSOUND
JMP ecall ; "emit call
exprsaveCALL pushe1 ; push entry
CALL exprax ; read expression
CALL pope1 ; restore entry
exintrt RET ; "
exint CALL exprax ; get integer expression: rd expr
CMP.B CL,#$0A ; integer ?
JZ exintrt ; yes:ret
CALL err ; 23:Integer expression expected
B $17 ; "
exnum CALL exprax ; get numeric expression: rd expr
CMP.B CL,#$0A ; integer ?
JZ exintrt ; yes: ret
CMP.B CL,#$09 ; real ?
JZ exintrt ; yes: ret
CALL err ; 26:Int or real expression expected
B $1A ; "
exscal CALL exprax ; get scalar expression: rd expr
chksimplCMP.B CL,#$0A ; scalar ?
JNB exscret ; :ok
CMP.B CL,#$08 ; string ?
CALL errnz ; no:
B $1F ; 31:Simple expression expected
MOV AX,#xstrch ; (string -> char)
CALL ecall ; * CALL xstrch
MOV CX,#$020C ; type: char in AX
exscret RET ; "
exstr CALL expr ; get string expression: do expr
CMP.B CL,#$08 ; string ?
JZ exstrret ; :yes
CMP.B CL,#$0C ; char ?
CALL errnz ; no:
B $21 ; 33:String expression expected
OR.B CH,CH ; constant ?
JNZ ecstrch ; :no
MOV AX,exres ; get result
MOV.B AH,AL ; char
MOV AL,#$01 ; length
CALL emovaxi ; * MOV AX,#...
JMP.b exstrch2 ; '
ecstrch CALL loadatom ; get atom
CALL ecode ; * MOV AH,AL
B $04,$8A,$E0,$B0,$01 ; * MOV AL,#01
exstrch2CALL epushax ; * PUSH AX
MOV CL,#$08 ; type = string
exstrretRET ; "
excond CALL expr ; evaluate boolean expr: do expr
CMP.B CL,#$0B ; boolean ?
CALL errnz ; no:
B $14 ; 20:Boolean expression expected
CALL loadatom ; get atom
CMP.B CH,#$04 ; comparision outside ?
JZ excondrt ; yes: ok
MOV AL,#$75 ; store branch op: JNZ
MOV brnchop,AL
CMP.B CH,#$03 ; flags set ?
JZ excondrt ; :yes
CALL ecode ; * OR AX,AX
B $02,$0B,$C0
excondrtRET ; "
exprax CALL expr ; read expression
expload CMP.B CL,#$0A ; scalar ?
JB excondrt ; below: ret
CALL loadatom ; get atom
JMP flgbool ; "flags -> boolean
expvar MOV AX,#expload ; do expression - var pre-read
PUSH AX ; set up return stack
MOV AX,#expr2
PUSH AX
MOV AX,#add2
PUSH AX
MOV AX,#mul2
PUSH AX
JMP cvar2 ; "start with var
expconstMOV AX,#expload ; do expression - const pre-read
PUSH AX ; set up return stack
MOV AX,#expr2
PUSH AX
MOV AX,#add2
PUSH AX
MOV AX,#mul2
PUSH AX
JMP cconst2 ; "start with const
expr CALL addlevel ; Comparison level: do add level
expr2 PUSH CX ; save type
CALL ckey ; check comparisons
B $02
W tkcmp
POP CX ; restore type
JZ cmp1 ; found: do comparison
RET ; '
cmp1 INC.B AL ; IN ?
JZ cmpin ; :yes
PUSH BX ; save op ptr, type
PUSH CX
CALL pushres ; save entry
PUSH pc ; save PC
PUSH functp ; save type ptr
CALL addlevel ; addition level
POP comptp ; restore type ptr
POP oldpc ; restore PC
POP DX ; restore type
CALL typeconv ; do type conversion
POP BX ; restore op ptr
CMP.B CL,#$0A ; scalar ?
JB cmpdiff ; :no
CS:
MOV.B AL,[BX]$01 ; set branch opcode
MOV brnchop,AL ; (from comparison table)
MOV BX,#cmpcode ; emit parms for comparison
CALL ecalc ; emit instruction
MOV CX,#$040B ; return type: boolean, flags set
RET ; '
cmpdiff CS: ; real, string, set, ptr comparisons
MOV.B BL,[BX] ; get offset in cmp table
XOR.B BH,BH ; -> table index
CMP.B CL,#$09 ; real ?
JZ cmpfnd ; :yes
INC BX ; +2
INC BX
CMP.B CL,#$08 ; string ?
JZ cmpfnd ; :yes
INC BX ; +2
INC BX
CMP.B CL,#$03 ; set ?
JZ cmpfnd ; :yes
INC BX ; +2 (pointer)
INC BX
cmpfnd CS:
MOV AX,[BX]vcompare ; get vector from table
OR AX,AX ; test it
CALL errz ; 47:Operand type(s) do
B $2F ; not match operator
JMP.b cmpemit ; 'end it
cmpin CALL loadatom ; IN: get atom
CALL epushax ; * PUSH AX
PUSH CX ; save type
CALL addlevel ; do addition level
POP DX ; restore type
CMP.B CL,#$03 ; set ?
CALL errnz ; 47:Operand type(s) do
B $2F ; not match operator
OR.B CH,CH ; constant ?
JZ cmpconst ; :yes
CMP.B DL,CH ; compare types
CALL errnz ; different base type:
B $2C ; 44:Type mismatch
cmpconstMOV AX,#xsetin
cmpemit CALL ecall ; * CALL xsetin
MOV CX,#$030B ; boolean, flags set
RET ; "
vcompareW realeq,csteq,seteq,ptreq ; = vector table for comparisons
W realne,cstne,setne,ptrne ; <>
W realge,cstge,setge ; >=
W $0000
W realle,cstle,setle ; <=
W $0000
W realg,cstg ; >
W $0000,$0000
W reall,cstl ; <
W $0000,$0000 ; "
addlevelCALL mullevel ; Addition level: do mult level
add2 PUSH CX ; save type
CALL ckey ; check add ops
B $05
W tkadd
POP CX ; restore type
JZ addptr ; :found
RET ; '
addptr CMP.B CL,#$04 ; pointer ?
CALL errz ; yes:
B $2F ; 47:Operand type(s) does not match op
PUSH BX ; save op ptr
PUSH CX ; save type
CALL pushres ; save first result
PUSH pc ; save PC
CALL mullevel ; mult level
CMP.B CL,#$0C ; char ?
JNZ add3 ; :no
OR.B CH,CH ; constant ?
JNZ addch ; :no
MOV AX,exres ; get resulting char
MOV.B AH,AL
MOV AL,#$01 ; convert to string
CALL emovaxi ; * MOV AX,#..
JMP.b addch2 ; '
addch CALL loadatom ; load second result
CALL ecode ; * MOV AH,AL
B $04,$8A,$E0,$B0,$01 ; * MOV AL,#01
addch2 CALL epushax ; * PUSH AX
MOV CL,#$08 ; convert to string
add3 POP oldpc ; restore PC
POP DX ; type first part
CALL typeconv ; do type conversions
POP BX ; restore op ptr
CS:
CMP.B [BX],#$02 ; OR, XOR ?
JNB addbool ; :yes
MOV AX,#sunion ; (set +)
MOV DX,#sdiff ; (set -)
CMP.B CL,#$03 ; set ?
JZ addset ; :yes
MOV AX,#xadd ; (add real)
MOV DX,#xsub ; (sub real)
CMP.B CL,#$09 ; real ?
JNZ addstr ; :no
addset CS:
CMP.B [BX],#$00 ; add ?
JZ addadd ; :yes
XCHG AX,DX ; get subtract vector
addadd CALL ecall ; emit call
JMP add2 ; 'loop back
addstr CMP.B CL,#$08 ; string ?
JNZ addscal ; :no
CS:
CMP.B [BX],#$00 ; add ?
CALL errnz ; no:
B $2F ; 47:Operand type(s) does not match op
MOV AX,#xconcat ; (concat strings)
JMP addadd ; 'emit call, loop back
addbool CMP.B CL,#$0B ; boolean ?
JZ addsc2 ; :yes
addscal CMP.B CL,#$0A ; scalar ?
CALL errnz ; no:
B $2F ; 47:Operand type(s) does not match op
addsc2 CALL ecalc ; emit instructions
JMP add2 ; "loop back
mullevelCALL neglevel ; Multiplication level: do unary level
mul2 PUSH CX ; save result type
CALL ckey ; check multiplication ops
B $05
W tkmul
POP CX ; restore type
JZ mulptr ; :found
RET ; '
mulptr CMP.B CL,#$04 ; pointer ?
CALL errz ; yes:
B $2F ; 47:Operand type(s) does not match op
PUSH BX ; save op ptr, type
PUSH CX
CALL pushres ; emit push first value
PUSH pc
CALL neglevel ; do unary level
POP oldpc ; restore old PC
POP DX ; type first op
POP BX ; op ptr
PUSH BX ; save it again
CS:
CMP.B [BX],#$01 ; division ?
JNZ mulnodiv ; :no
CMP.B CL,#$0A ; second = integer ?
JNZ mulnodiv ; :no
CALL loadatom ; load result
MOV AX,#xintreal ; convert to real
CALL ecall ; * CALL xintreal
MOV CL,#$09 ; now real
mulnodivCALL typeconv ; do type conversions
POP BX ; op ptr
CS:
CMP.B [BX],#$01 ; division ?
JA muland ; higher: no reals, sets
JZ muldiv ; :division
MOV AX,#xmul ; (multiply real)
CMP.B CL,#$09 ; real ?
JZ mulreal ; :yes
MOV AX,#sinter ; (set *)
CMP.B CL,#$03 ; set ?
JNZ muland ; no: go out
mulreal CALL ecall ; emit call
JMP mul2 ; 'loop back
muldiv MOV AX,#xdiv ; (divide real)
CMP.B CL,#$09 ; real ?
JZ mulreal ; :yes
CALL err ; 47:Operand type(s) does not match op
B $2F ; '
muland CS: ; AND ?
CMP.B [BX],#$02
JNZ mulscal ; :no
CMP.B CL,#$0B ; boolean ?
JZ mulemit ; :yes
mulscal CMP.B CL,#$0A ; scalar ?
CALL errnz ; no:
B $2F ; 47:Operand type(s) does not match op
mulemit CALL ecalc ; emit arithmetic op
JMP mul2 ; "loop back
neglevelCALL ctoken ; Unary level
W tknot ; NOT ?
JNZ negneg ; :no
CALL negneg ; do negation level
CALL flgbool ; flags -> boolean
CMP.B CL,#$0A ; integer ?
JZ negnot ; :ok
CMP.B CL,#$0B ; boolean ?
CALL errnz ; no:
B $2F ; 47:Operand type(s) does not match op
CALL loadatom ; load value
CALL ecode ; * XOR AL,#01
B $02,$34,$01
MOV CH,#$03 ; flags set...
RET ; '
negnot CALL loadatom ; get value
CALL ecode ; * NOT AX
B $02,$F7,$D0
RET ; '
negneg PUSH negflg ; do negation: save flag
CALL testsign ; test sign
MOV negflg,DX ; store it
CALL atom ; do atom
MOV DX,negflg ; get neg flag
CALL testnum ; test type
JZ negend ; :ok
CMP.B CL,#$0A ; integer ?
JNZ negreal ; :no
CALL loadatom ; get value
CALL ecode ; * NEG AX
B $02,$F7,$D8
JMP.b negend ; '
negreal MOV AX,#xneg ; (negate real)
CALL ecall
negend POP negflg ; restore neg flag
RET ; "
pushres CALL flgbool ; store result on stack
CMP.B CL,#$0A ; integer ?
JB pushptr ; :no
CALL loadatom ; get value
MOV.B flgpshax,#$01 ; set flag: PUSH AX
RET ; '
pushptr CMP.B CL,#$04 ; pointer ?
JNZ pushret ; :no
CALL ecode ; * PUSH DX
B $02,$52,$50 ; * PUSH AX
pushret RET ; "
typeconvCALL flgbool ; Do type conversions
MOV.B flgpshax,#$00 ; no PUSH AX
CMP.B DL,#$09 ; first = real ?
JNZ tcvstr ; :no
CMP.B CL,#$0A ; second = integer ?
JNZ tcvreal ; :no
CALL loadatom ; get value
MOV AX,#xintreal
CALL ecall ; * CALL xintreal
MOV CL,#$09 ; -> real
JMP.b tcvreal ; '
tcvstr CMP.B DL,#$08 ; first = string ?
JNZ tcvreal ; :no
CMP.B CL,#$0C ; second = char ?
JNZ tcvreal ; :no
OR.B CH,CH ; constant ?
JNZ tcvchstr ; :no
MOV AX,exres ; get char
MOV.B AH,AL ; convert to string
MOV AL,#$01
CALL emovaxi ; * MOV AX,#i
JMP.b tcvchst2 ; '
tcvchstrCALL loadatom ; get value
CALL ecode ; * MOV AH,AL (convert to string)
B $04,$8A,$E0,$B0,$01 ; * MOV AL,#01
tcvchst2CALL epushax ; * PUSH AX
MOV CL,#$08 ; -> string
tcvreal CMP.B CL,#$09 ; second = real ?
JNZ tcvchst1 ; :no
CMP.B DL,#$0A ; first = integer ?
JNZ tcvint ; :no
MOV AX,#xintre2 ; convert first number
CALL ecall
MOV DL,#$09 ; first -> real
JMP.b tcvint ; '
tcvchst1CMP.B CL,#$08 ; second = string ?
JNZ tcvint ; :no
CMP.B DL,#$0C ; first = char ?
JNZ tcvint ; :no
MOV AX,#xchstr ; first -> string
CALL ecall ; * CALL xchstr1
MOV DL,#$08 ; -> string
tcvint CMP.B CL,#$0A ; second = integer ?
JB tcvnoint ; :no
CMP.B CH,#$02 ; calculated ?
JNZ tcvpop ; :no
CALL ecode ; * POP CX
B $01,$59
JMP.b tcvchk ; '
tcvpop MOV AX,pc ; PC = old PC ?
CMP AX,oldpc
JZ tcvchk ; :yes
CALL epopax ; * POP AX
JMP.b tcvchk ; '
tcvnointCMP.B CL,#$04 ; pointer ?
JNZ tcvchk ; :no
CALL ecode ; * POP BX
B $02,$5B,$59 ; * POP DX
tcvchk CMP.B CL,DL ; first = second ?
CALL errnz ; no:
B $2C ; 44:Type mismatch
CMP.B CL,#$03 ; set ?
JNZ tcvset ; :no
CMP.B CH,DH ; same base types !
JZ tcvret ; :ok
OR.B DH,DH ; constant 1 ?
JZ tcvret ; yes: ret
OR.B CH,CH ; constant 2 ?
MOV.B CH,DH ; copy base type
JZ tcvret ; yes: ret
CALL err ; 44:Type mismatch
B $2C ; '
tcvset CMP.B CL,#$04 ; pointer ?
JNZ tcvret ; :no
CMP functp,#$00 ; untyped ?
JZ tcvret ; yes: ret
CMP comptp,#$00 ; untyped ?
JZ tcvret ; yes: ret
MOV AX,functp ; get type ptr
CMP AX,comptp ; compare
JZ tcvret ; equal: ok
CALL err ; 44:Type mismatch
B $2C ; '
tcvret RET ; "
loadatomOR.B CH,CH ; load value -> AX
JNZ latvar ; :no constant
MOV AX,exres ; get result
CALL emovaxi ; * MOV AX,#result
JMP.b latres ; '
latvar CMP.B CH,#$01 ; var ?
JNZ latret ; no: ret - already in AX
PUSH CX ; save
PUSH DX
CALL eload ; load var
POP DX
POP CX
latres MOV CH,#$02 ; flag: in AX
latret RET ; "
flgbool CMP.B CL,#$0B ; Flags -> boolean
JNZ flgbret ; :no boolean
CMP.B CH,#$03 ; flags set ?
JB flgbret ; :constant, var, AX
JZ flgbres ; flags set: ok
CALL ecode ; convert
B $03,$B8,$01,$00 ; * MOV AX,#0001
MOV AL,brnchop
CALL ebyte ; emit branch op
CALL ecode ; * offset
B $02,$01,$48 ; * DEC AX
flgbres MOV CH,#$02 ; flag: result in AX
flgbret RET ; "
ecalc PUSH CX ; Emit arithmetic operation
OR.B CH,CH ; second = const ?
JNZ ecvar ; :no
CS:
TEST.B [BX]$04,#$02 ; is there a const form ?
JNZ ecnocn ; :no
CS:
MOV.B AL,[BX]$01 ; get its opcode
CALL ebyte ; emit it
MOV AX,exres ; emit the result
CALL eword ; as immediate value
JMP.b ecxchg2 ; 'done
ecnocn MOV AX,exres ; take immediate
CALL emovcxi ; * MOV CX,#result
JMP.b ecnoxchg ; '
ecvar CMP.B CH,#$01 ; variable ?
JNZ eccalc ; :no
CS:
TEST.B [BX]$04,#$04 ; is there a var form ?
JNZ ecnovar ; :no
CS:
TEST.B [BX]$04,#$08 ; CWD needed ?
JZ eccwd1 ; :no
CALL ecode
B $01,$99 ; * CWD
eccwd1 CS:
MOV DX,[BX]$02 ; base opcode
AND.B DH,#$38 ; convert to AX,var
CALL einstr ; emit instruction
JMP.b ecxchg2 ; 'done
ecnovar MOV DX,#$088B ; * MOV CX,...
CALL einstr ; emit instruction
JMP.b ecnoxchg ; '
eccalc CS: ; second number in AX
TEST.B [BX]$04,#$01 ; XCHG needed ?
JZ ecnoxchg ; :no
CALL ecode
B $01,$91 ; * XCHG CX,AX
ecnoxchgCS:
TEST.B [BX]$04,#$08 ; CWD needed ?
JZ eccwd2 ; :no
CALL ecode
B $01,$99 ; * CWD
eccwd2 CS:
MOV DX,[BX]$02 ; base opcode
CALL emitdx ; emit it
ecxchg2 CS:
TEST.B [BX]$04,#$10 ; second XCHG needed ?
JZ ecres ; :no
CALL ecode
B $01,$92 ; * XCHG DX,AX (for MOD)
ecres POP CX ; restore type
MOV CH,#$02 ; result in AX
RET ; "
atom CALL cvar ; Do atom: do var
JZ atomret ; :done
CALL cconst ; do constant
JZ atomret ; :done
CALL cfunc ; do function
JZ atomret ; :done
CALL cset ; do set
JZ atomret ; :done
CALL cparens ; do parentheses
JZ atomret ; :done
CALL cstdfn ; do standard functions
JZ atomret ; :done
CALL ctype ; do type conversions
JZ atomret ; :done
CALL cnil ; test for NIL
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
atomret RET ; "
cvar CALL rdvar ; get var
JNZ atomret ; no:ret
cvar2 MOV AL,varctp ; component type:
CMP AL,#$0A ; integer ?
JB cvareal ; :below
MOV CH,#$01 ; var
CMP varsize,#$01 ; byte ?
JA cvaint ; :no, word
CALL eload ; load var
MOV CH,#$02 ; now in AX
cvaint MOV.B CL,varctp ; get component type
JMP.b cvaok ; 'ok
cvareal CMP AL,#$09 ; real ?
JZ cvaload ; :yes
CMP AL,#$08 ; string ?
JZ cvaload ; :yes
CMP AL,#$03 ; set ?
JZ cvaload ; :yes
CMP AL,#$04 ; pointer ?
JNZ cvaarrch ; :no
cvaload CALL eload ; load var
MOV BP,lower ; type ptr
MOV functp,BP
MOV.B CL,varctp ; component type
CMP.B CL,#$03 ; set ?
JNZ cvaok ; :no, ok
MOV.B CH,[BP]-$08 ; get base type
JMP.b cvaok ; 'ok
cvaarrchCMP AL,#$01 ; array ?
CALL errnz ; no:
B $3E ; 62:Struct vars are not allowed here
CALL varptr2 ; get var ptr
MOV BP,lower ; type ptr
CMP.B [BP]-$08,#$0C ; array of char ?
CALL errnz ; no:
B $3E ; 62:Struct vars are not allowed here
MOV BP,upper ; index type
CMP.B [BP]-$08,#$0A ; = scalar ?
CALL errnz ; no:
B $3E ; 62:Struct vars are not allowed here
MOV AX,varsize ; component size
OR.B AH,AH ; > 255 ?
CALL errnz ; yes:
B $3E ; 62:Struct vars are not allowed here
MOV.B AH,AL
MOV AL,#$B1
CALL eword ; * MOV CL,#len
MOV AX,#xldarrch ; (load array of char)
CALL ecall ; * CALL xldarrch
MOV CL,#$08
cvaok XOR AX,AX ; ok
RET ; "
cconst CALL constel ; get constant element
JNZ ccnret ; no good: ret
MOV DX,negflg ; negation flag
CALL donegate ; do negation
MOV negflg,#$0000 ; clear neg flag
cconst2 CMP.B CL,#$09 ; real ?
JNZ ccnstr ; :no
MOV AX,#xrealcn ; (load real constant)
CALL ecall ; * CALL xrealcn
MOV AX,creal1 ; emit real constant
CALL eword ; as inline code
MOV AX,creal2
CALL eword
MOV AX,creal3
CALL eword
JMP.b ccnok ; 'ok
ccnstr CMP.B CL,#$08 ; string ?
JNZ ccnscal ; :no
MOV AX,#xstrcn ; (get inline string)
CALL ecall ; * CALL xstrcn
PUSH CX ; save
CALL estring ; emit string
POP CX
JMP.b ccnok ; 'ok
ccnscal MOV exres,BX ; store result
XOR.B CH,CH ; type: constant
ccnok XOR AX,AX ; ok
ccnret RET ; "
cfunc MOV CX,#$0600 ; Do function
CALL search ; search it
JNZ cfnret ; not found: ret
CALL estkchk ; emit stack check
MOV BX,[BP]-$02 ; result type ptr
SS:
MOV AX,[BX]-$02 ; result type size
CALL allotstk ; allot stack space for result
CALL cproc2 ; call function (like procedure)
CALL getvprm ; get var parms
MOV AX,lower ; result type ptr
MOV functp,AX
MOV.B CL,varctp ; component type
MOV CH,#$02 ; result in AX / on stack
CMP.B CL,#$0B ; boolean ?
JNZ cfnok ; :no
MOV CH,#$03 ; flags set
cfnok XOR AX,AX ; ok
cfnret RET ; "
allotstkCMP AX,#$0002 ; Allocate space on stack
JA astksub ; :offset > 2
XCHG AX,CX ; offset -> CX
JCXZ cfnret ; :nothing to allot
astkdec CALL ecode ; * DEC SP
B $01,$4C
LOOP astkdec ; :another byte
RET ; '
astksub CALL offslen ; short or long offset
MOV DX,#$EC83 ; short
JZ astkshrt ; :short
MOV DL,#$81 ; long
astkshrtPUSH AX ; save AX
CALL emitdx ; * SUB SP,#....
POP AX ; restore
TEST.B DL,#$02 ; short ?
JZ astklong ; :no
JMP ebyte ; 'emit byte offset
astklongJMP eword ; "emit word offset
cset CALL csqr1 ; Do set: [ ?
JNZ csetret ; no:ret
MOV AX,#sldempty ; (make empty set)
CALL ecall ; * CALL sldempty
CALL csqr2 ; ] ?
MOV CX,#$0003 ; type: untyped set
JZ csetret ; :yes
csetlp PUSH CX ; save type
CALL exscal ; get scalar expression
MOV.B AL,CL ; type read
POP CX ; restore type
OR.B CH,CH ; typed set ?
JNZ csetcn ; :yes
MOV.B CH,AL ; set type from const read
csetcn CMP.B AL,CH ; compare base type
CALL errnz ; not equal:
B $2C ; 44:Type mismatch
PUSH CX ; save type
CALL ctoken ; .. ?
W tk2dot
MOV AX,#setincl ; (include element in set)
JNZ csetincl ; :no
CALL epushax ; * PUSH AX
CALL exscal ; get scalar expr
MOV.B AL,CL ; result type
POP CX
PUSH CX
CMP.B AL,CH ; = type of set ?
CALL errnz ; no:
B $2C ; 44:Type mismatch
MOV AX,#setinrng ; (include range in set)
csetinclCALL ecall ; emit call
POP CX ; restore type
CALL ccomma ; , ?
JZ csetlp ; yes: loop back
CALL esqr2 ; ! ]
XOR AX,AX ; ok
csetret RET ; "
cparens CALL cbrack1 ; Do parentheses: ( ?
JNZ cparret ; no:ret
CALL expr ; get expression
CALL ebrack2 ; ! )
XOR AX,AX ; ok
cparret RET ; "
ctype MOV CX,#$0300 ; Do type conversions
CALL search ; search type
JNZ ctpret ; not found: ret
MOV BP,[BP]-$02 ; get type ptr
MOV.B AL,[BP]-$08 ; get component type
CMP AL,#$0A ; scalar ?
CALL errb ; no:
B $1E ; 30:Simple type expected
PUSH AX ; save type
CALL ebrack1 ; ! (
CALL expr ; get expression
CALL ebrack2 ; ! )
CALL chksimpl ; check simple type
POP AX ; restore type
MOV.B CL,AL ; convert to type wanted
XOR AX,AX ; ok
ctpret RET ; "
cnil CALL ctoken ; test for NIL
W tknil
JNZ cnilret ; no:ret
CALL ecode ; * XOR AX,AX
B $04,$33,$C0,$33,$D2 ; * XOR DX,DX
MOV CL,#$04 ; type: pointer
XOR AX,AX ; ok
MOV functp,AX ; untyped ptr
cnilret RET ; "
cstdfn CALL ckey ; Do standard functions
B $02
W stdfuncs
JNZ csfret ; not found: ret
CS:
CALL [BX] ; call compiler routine
MOV CH,#$02 ; flag: result in AX
CMP.B CL,#$0B ; boolean ?
JNZ csfok ; :no
MOV CH,#$03 ; flags set
csfok XOR AX,AX ; ok
csfret RET ; "
fsqr CALL getnum ; SQR (num)
CMP.B CL,#$0A ; integer ?
JNZ fsqr2 ; :no
CALL ecode
B $02,$F7,$E8 ; * IMUL AX
RET ; '
fsqr2 MOV AX,#xsqr ; (sqr real)
fsqremitJMP ecall ; "emit call
fabs CALL getnum ; ABS (num)
MOV AX,#iabs ; (abs integer)
CMP.B CL,#$0A ; integer ?
JZ fsqremit ; yes: emit call
MOV AX,#xabs ; (abs real)
JMP fsqremit ; "
fsqrt MOV AX,#xsqrt ; SQRT
JMP.b freal ; '
fsin MOV AX,#xsin ; SIN
JMP.b freal ; '
fcos MOV AX,#xcos ; COS
JMP.b freal ; '
farctan MOV AX,#xarctan ; ARCTAN
JMP.b freal ; '
fln MOV AX,#xln ; LN
JMP.b freal ; '
fexp MOV AX,#xexp ; EXP
JMP.b freal ; '
fint MOV AX,#xint ; INT
JMP.b freal ; '
ffrac MOV AX,#xfrac ; FRAC
freal PUSH AX ; save function addr
CALL getnum ; (num)
CMP.B CL,#$09 ; real ?
JZ freal2 ; :yes
MOV AX,#xintreal ; (integer -> real)
CALL ecall
MOV CL,#$09 ; now: real
freal2 POP AX ; restore addr
JMP ecall ; "emit call
ftrunc MOV AX,#xtrunc ; TRUNC
JMP.b frnd2 ; '
fround MOV AX,#xround ; ROUND
frnd2 PUSH AX ; save addr
CALL getnum ; (num)
POP AX ; restore
CMP.B CL,#$0A ; integer ?
JNZ frndemit ; :no
RET ; 'int: do nothing
frndemitMOV CL,#$0A ; convert to integer
JMP ecall ; "emit call
fsucc MOV AL,#$40 ; SUCC: INC AX
JMP.b fpred2 ; '
fpred MOV AL,#$48 ; PRED: DEC AX
fpred2 PUSH AX ; save opcode
CALL getscal ; (scal)
POP AX ; restore op
JMP ebyte ; "emit it
flo CALL getint ; LO: (int)
CALL ecode
B $02,$32,$E4 ; * XOR AH,AH
RET ; "
fhi CALL getint ; HI: (int)
CALL ecode ; * MOV AL,AH
B $04,$8A,$C4,$32,$E4 ; * XOR AH,AH
RET ; "
fswap CALL getint ; SWAP: (int)
CALL ecode
B $02,$86,$C4 ; * XCHG AH,AL
RET ; "
fodd CALL getint ; ODD: (int)
CALL ecode
B $03,$25,$01,$00 ; * AND AX,#0001
MOV CL,#$0B ; boolean result
RET ; "
fkeypresMOV AX,#xkeypres ; KEYPRESSED
MOV CL,#$0B ; result: boolean
JMP ecall ; "emit call
ford CALL getscal ; ORD: (scalar)
MOV CL,#$0A ; result: integer
RET ; "
fchr CALL getint ; CHR: (int)
MOV CL,#$0C ; result: char
RET ; "
flength CALL ebrack1 ; ! ( : LENGTH
MOV AX,#xlength
flen2 PUSH AX ; save addr
CALL exstr ; get string expression
CALL ebrack2 ; ! )
POP AX ; restore addr
JMP frndemit ; "int result, emit call
fpos CALL ebrack1 ; ! ( : POS
CALL exstr ; get string expression
CALL ecomma ; ! ,
MOV AX,#xpos
JMP flen2 ; "get second string expr
fcopy CALL ebrack1 ; ! ( : COPY
CALL exstr ; get string expr
CALL ecomma ; ! ,
CALL exint ; get int expr
CALL ecomma ; ! ,
CALL epushax ; * PUSH AX
CALL exint ; get int expr
MOV AX,#xcopy
CALL ecall ; emit call
fcopemitCALL ebrack2 ; ! )
MOV CL,#$08 ; result: string
RET ; "
fconcat CALL ebrack1 ; ! ( : CONCAT
CALL exstr ; get string expr
fconlp CALL ccomma ; , ?
JNZ fcopemit ; no:end it
CALL exstr ; get string expr
MOV AX,#xconcat
CALL ecall ; emit call
JMP fconlp ; "another string ?
fparmcntMOV AX,#xparmcnt ; PARAMCOUNT
JMP frndemit ; "result: integer
fparmstrCALL getint ; PARAMSTR: (int)
MOV AX,#xparmstr
MOV CL,#$08 ; result: string
JMP ecall ; "emit call
frandom CALL cbrack1 ; RANDOM: ( ?
MOV AX,#xrandom ; (random real)
MOV CL,#$09 ; result: real
JNZ frndreal ; no (: take real
CALL exint ; get int expr
CALL ebrack2 ; ! )
MOV AX,#irandom ; (random int)
femitintMOV CL,#$0A ; result: integer
frndrealJMP ecall ; "emit call
fiores MOV AX,#xiores ; IORESULT
JMP femitint ; "-> integer
feof CALL getfil ; EOF: (file)
MOV BX,#veof ; ptr to vector table
CALL ecallio ; emit call for I/O
femitbooMOV CL,#$0B ; result: boolean
RET ; "
fseekeofMOV AX,#xseekeof ; SEEKEOF
JMP.b feo2 ; '
fseekeolMOV AX,#xseekeol ; SEEKEOLN
JMP.b feo2 ; '
feoln MOV AX,#xeoln ; EOLN
feo2 PUSH AX ; save addr
CALL getfil ; (file)
CMP.B CL,#$06 ; text file ?
CALL errnz ; no:
B $23 ; 35:Textfile expected
POP AX ; restore addr
CALL ecall ; emit call
JMP femitboo ; "result: boolean
ffilpos MOV AX,#xfilepos ; FILEPOS
JMP.b ffil2 ; '
ffilsizeMOV AX,#xfilesiz ; FILESIZE
ffil2 PUSH AX ; save addr
CALL getfil ; (file)
POP AX ; addr
CMP.B CL,#$06 ; text file ?
CALL errz ; yes:
B $3F ; 63:Textfiles are not allowed here
JMP femitint ; "int result, emit call
flfilposMOV AX,#xlfilpos ; LONGFILEPOS
JMP.b flf2 ; '
flfilsizMOV AX,#xlfilsiz ; LONGFILESIZE
flf2 PUSH AX ; save addr
CALL getfil ; (file)
POP AX ; addr
CMP.B CL,#$06 ; text file ?
CALL errz ; yes:
B $3F ; 63:Textfiles are not allowed here
MOV CL,#$09 ; result: real
JMP ecall ; "emit call
fmemavl MOV AX,#xmemavl ; MEMAVAIL
JMP femitint ; "int result, emit call
fmaxavl MOV AX,#xmaxavl ; MAXAVAIL
JMP femitint ; "int result, emit call
faddr CALL ebrack1 ; ! ( : ADDR
CALL varptr ; get var ptr
CALL ecode ; * POP DX
B $02,$5A,$97 ; * XCHG DI,AX
fretptr CALL ebrack2 ; ! )
MOV CL,#$04 ; result: pointer
MOV functp,#$0000 ; untyped
RET ; "
fptr CALL ebrack1 ; ! ( : PTR
CALL exint ; get int expr
CALL ecomma ; ! ,
CALL epushax ; * PUSH AX
CALL exint ; get int expr
CALL ecode ; * POP DX (segment)
B $01,$5A
JMP fretptr ; "expect ), pointer
fofs CALL ebrack1 ; ! ( : OFS
MOV CX,#$0500 ; search procedure
CALL search
JZ fofsproc ; :found
MOV CX,#$0600 ; search function
CALL search
JNZ fofsvar ; :not found
fofsprocMOV AX,[BP]-$08 ; get offset
fofsimmeCALL emovaxi ; * MOV AX,#proc_offset
JMP.b fofsint ; 'type: integer
fofsvar CALL rdvar ; get var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
CALL loadoffs ; get offset
CALL ecode ; * XCHG DI,AX
B $01,$97 ; (offset -> AX)
fofsint CALL ebrack2 ; ! )
MOV CL,#$0A ; result: integer
RET ; "
fseg CALL ebrack1 ; ! ( : SEG
CALL rdvar ; get var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
MOV AL,#$8C ; (MOV AX,DS)
MOV AH,#$D8
CMP.B varseg,#$FF ; DS ?
JZ fsegemit ; yes: ok
MOV AH,#$C0 ; (MOV AX,ES)
CMP.B varseg,#$FD ; ES ?
JZ fsegemit ; yes: ok
MOV AH,#$D0 ; (MOV AX,SS)
JB fsegemit ; below: ok
MOV AH,#$C8 ; (MOV AX,CS)
fsegemitCALL eword ; emit word
JMP fofsint ; "expect ), integer
fsizeof CALL ebrack1 ; ! ( : SIZEOF
MOV CX,#$0300 ; search type
CALL search
JNZ fszvar ; :not found
MOV BP,[BP]-$02 ; type ptr
MOV AX,[BP]-$02 ; get component size
CALL emovaxi ; * MOV AX,#compo_size
JMP fofsimme ; '(Bug: redundant load !)
fszvar CALL rdvar ; get var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
MOV AX,varsize ; get component size
JMP fofsimme ; "emit MOV AX,#.., integer
fdseg CALL ecode ; DSEG
B $02,$8C,$D8 ; * MOV AX,DS
JMP.b fsseg2 ; 'int result
fcseg CALL ecode ; CSEG
B $02,$8C,$C8 ; * MOV AX,CS
JMP.b fsseg2 ; 'int result
fsseg CALL ecode ; SSEG
B $02,$8C,$D0 ; * MOV AX,SS
fsseg2 MOV CL,#$0A ; integer
RET ; "
fportw MOV AL,#$ED ; PORTW
JMP.b fprt2 ; '(IN AX,[DX])
fport MOV AL,#$EC ; PORT (INB AL,[DX])
fprt2 PUSH AX ; save opcode
CALL esqr1 ; ! [
CALL exint ; get int expr
CALL esqr2 ; ! ]
CALL ecode
B $01,$92 ; * XCHG DX,AX (port number)
POP AX ; restore opcode
CALL ebyte ; emit it
CMP AL,#$ED ; integer ?
JZ fsseg2 ; :yes
CALL ecode ; byte:
B $02,$32,$E4 ; * XOR AH,AH
JMP fsseg2 ; "int result
fupcase CALL getscal ; UPCASE: (scalar)
MOV CL,#$0C ; result: char
MOV AX,#xupcase
JMP ecall ; "emit call
fwherex MOV AX,#xwherex ; WHEREX
JMP femitint ; "int result, emit call
fwherey MOV AX,#xwherey ; WHEREY
JMP femitint ; "int result, emit call
veof W xeofty,xeoftx,xeofty ; "EOF vector table
getint CALL ebrack1 ; ! ( : get (int)
CALL exint ; get int expr
JMP ebrack2 ; "! )
getnum CALL ebrack1 ; ! ( : get (num)
CALL exnum ; get num expr
JMP ebrack2 ; "! )
getscal CALL ebrack1 ; ! ( : get (scalar)
CALL exscal ; get scalar expr
JMP ebrack2 ; "! )
getfil CALL cbrack1 ; get (file): ( ?
JNZ gtfstd ; :no
CALL rdfilvar ; get file var
JNB gtf2 ; :ok
CALL err ; 41:Unknown ID or syntax error
B $29 ; '
gtf2 CALL errnz ; not file var:
B $15 ; 21:File var expected
JMP ebrack2 ; '! )
gtfstd CALL ecode ; set ptr to std input file
B $04,$BF,$5A,$01,$1E ; * MOV DI,#stdin
MOV CL,#$06 ; * PUSH DS
MOV.B varctp,CL ; type: text file
RET ; "
fullvar CALL rdconst ; Do full var: read constant
JNZ rdvar ; no good: read var
CMP.B CL,#$08 ; string constant ?
CALL errnz ; no:
B $3C ; 60:Constants are not allowed here
MOV AL,#$EB ; JMP
MOV.B AH,CH ; offset: length of string
CALL eword ; emit branch around string constant
MOV AX,pc ; save current pos
MOV varofs,AX ; -> offset of var
MOV.B indflg,#$00 ; not indexed
MOV.B varseg,#$FE ; segment CS
MOV.B varctp,#$01 ; type: array
MOV AX,ptcbeg ; std type: char
SUB AX,#$0062
MOV lower,AX ; -> type pointer
XOR AX,AX ; no index type
MOV upper,AX
MOV.B AL,CH ; length -> component size
MOV varsize,AX
CALL estr2 ; emit array of char
XOR AX,AX ; ok
RET ; '
rdvar CALL indwith ; do WITH-indexing
JZ rdvarlp ; :done
MOV CX,#$0400 ; search var
CALL search
JNZ rvamem ; not found: try MEM
CALL getvprm ; get var parms
rdvarindMOV.B indflg,#$00 ; flag: not indexed
CMP.B indptflg,#$00 ; indirect by ptr ?
JZ rdvarlp ; :no
CALL indptrld ; get ptr to var
rdvarlp CALL indarray ; do array indexing
JZ rdvarlp ; done: loop
CALL indrec ; do record indexing
JZ rdvarlp ; done: loop
CALL indptr ; do pointer indexing
JZ rdvarlp ; done: loop
CALL indstr ; do string indexing
XOR AX,AX ; ok
RET ; '
rvamem CALL ckey ; search keyword:
B $01 ; MEM / MEMW
W tkmem
JNZ rvaret ; not found: ret
CS:
MOV.B AL,[BX] ; get component size
PUSH AX ; save it
CALL esqr1 ; ! [
CALL exint ; get int expr
CALL epushax ; * PUSH AX (segment)
CALL ecolon ; ! :
CALL exint ; get int expr
CALL esqr2 ; ! ]
CALL ecode ; * XCHG DI,AX
B $02,$97,$07 ; * POP ES
POP AX ; get length flag
XOR.B AH,AH ; clr hi
MOV varsize,AX ; -> component size
MOV.B varctp,#$0A ; type integer
CMP AL,#$01 ; byte ?
JNZ rvamemw ; :no
MOV lower,#$0000 ; set lower, upper bound
MOV upper,#$00FF
JMP.b rvamemb ; '
rvamemw MOV lower,#$8000 ; set lower, upper bound
MOV upper,#$7FFF
rvamemb MOV varofs,#$0000 ; var offset: none
MOV.B indflg,#$FF ; indexed
MOV.B varseg,#$FD ; segment ES
XOR AX,AX ; ok
rvaret RET ; "
indwith MOV.B BL,withnest ; Do WITH indexing
XOR.B BH,BH ; with nesting -> count
iwloop DEC BX ; count down
JNS iw1 ; :another level to test
RET ; '
iw1 PUSH BX ; save counter
SHL BX,1 ; * 4
SHL BX,1 ; -> pointer into with-table
MOV CX,[BX]withtab ; type
PUSH CX
PUSH [BX]withtab1 ; position
MOV CH,#$04 ; search var (record num)
CALL search
POP AX ; restore pos, type, counter
POP CX
POP BX
JNZ iwloop ; not found: do next level
MOV.B indflg,#$00 ; flag: not indexed
CMP AX,#$FFFF ; indexed WITH ?
JZ iwvar ; :yes
MOV.B varseg,CH ; get offset from with-table
MOV varofs,AX
JMP.b iwconst ; 'do record indexing
iwvar PUSH BP ; save symtab pos
MOV.B BL,CH ; get stack offset
SHL BX,1
MOV AX,varspc ; stack usage
SUB AX,BX ; - position
MOV varofs,AX ; -> offset
MOV AL,lexnest ; lexical nesting
MOV varseg,AL ; -> var segment
CALL indptrld ; get pointer to var
POP BP ; restore symtab ptr
iwconst JMP iraddofs ; "do record indexing
indstr CMP.B varctp,#$08 ; Do string indexing
JNZ iaret ; no string: ret
CALL csqr1 ; [ ?
JNZ iaret ; no: ret
MOV AX,ptcbeg ; point to char type
SUB AX,#$0062
MOV lower,AX ; -> type ptr
JMP.b ialoop ; "get index
indarrayCMP.B varctp,#$01 ; Do array indexing
JNZ iaret ; no array: ret
CALL csqr1 ; [ ?
JZ ialoop ; yes: do it
iaret RET ; '
ialoop MOV AX,flgpshes ; flag: emit PUSH ES
CMP.B varseg,#$FD ; segment ES ?
JNZ ialp2 ; :no
MOV.B flgpshes,#$01 ; set flag
ialp2 CMP.B indflg,#$00 ; indexed ?
JZ ianoind ; :no
MOV.B flgpshdi,#$01 ; set flag: emit PUSH DI
ianoind CALL pushe1 ; push entry
PUSH pc ; save PC, flag
PUSH AX
CALL expr ; evaluate expression
POP AX ; restore
CMP flgpshes,#$00 ; flag = 0 ?
JZ iarest ; :yes
MOV flgpshes,AX ; restore flag
iarest POP AX ; old PC
SUB AX,pc ; anything emitted ?
OR.B CH,CH ; constant ?
JZ ianosto ; :yes
PUSH AX ; save
PUSH CX
CALL expload ; load result
POP CX
POP AX
ianosto CALL pope1 ; restore entry
OR AX,AX ; test flag
JZ ianopop ; :not set
CMP.B indflg,#$00 ; indexed ?
JZ ianoind2 ; :no
CALL ecode ; * POP DI
B $01,$5F
ianoind2CMP.B varseg,#$FD ; segment ES ?
JNZ ianopop ; :no
CALL ecode ; * POP ES
B $01,$07
ianopop CMP.B varctp,#$08 ; string ?
JNZ ianostr ; :no
MOV.B var2ctp,#$0A ; component type = scalar
MOV lower2,#$0000 ; lower bound
MOV AX,varsize ; component size - 1
DEC AX
MOV upper2,AX ; -> upper bound
JMP.b iastr ; '
ianostr MOV BP,upper ; index type ptr
CALL getparm ; get type parms
iastr MOV BP,lower ; type ptr
CALL getvprm2 ; get type parms
CMP.B CL,var2ctp ; type = index type ?
CALL errnz ; no:
B $2C ; 44:Type mismatch
OR.B CH,CH ; constant index ?
JNZ iavarind ; :no
MOV AX,exres ; get result
CMP AX,lower2 ; < lower bound ?
JL iaerr ; yes: error
CMP AX,upper2 ; > upper bound ?
JLE iacnind ; no: ok
iaerr CALL err ; 45:Constant out of range
B $2D ; '
iacnind SUB AX,lower2 ; subtract lower bound
MOV CX,varsize ; * component size
MUL CX
ADD varofs,AX ; add to var offset
JMP iaind ; 'store it
iavarindMOV AX,lower2 ; lower bound
TEST direcsv,#$0002 ; range check ?
JNZ iarngind ; :yes
MOV CX,varsize ; lower bound * component size
MUL CX
SUB varofs,AX ; subtract from var offset
JMP.b iacnind2 ; '-> faster array indexing
iarngindOR AX,AX ; subtract lower bound from index
JZ iaoff2 ; 0:done
CMP AX,#$0001 ; 1 ?
JNZ iaoff ; :no
CALL ecode
B $01,$48 ; * DEC AX
JMP.b iaoff2 ; '
iaoff CALL ecode
B $01,$2D ; * SUB AX,#lower_bound
CALL eword
iaoff2 MOV AX,upper2 ; upper bound-lower bound+1
SUB AX,lower2
INC AX
CALL emovcxi ; * MOV CX,#ind_count
MOV AX,#xindchk ; (range check)
CALL ecall ; * CALL xindchk
iacnind2MOV AX,varsize ; index * component size
CMP AX,#$0001 ; component size = 1 ?
JZ iacsend ; yes: ok
CMP AX,#$0002 ; = 2 ?
JNZ iacs4 ; :no
CALL ecode
B $02,$D1,$E0 ; * SHL AX,1
JMP.b iacsend ; '
iacs4 CMP AX,#$0004 ; = 4 ?
JNZ iacs6 ; :no
CALL ecode ; * SHL AX,1
B $04,$D1,$E0,$D1,$E0 ; * SHL AX,1
JMP.b iacsend ; '
iacs6 CMP AX,#$0006 ; = 6 ?
JNZ iacs ; :no
CALL ecode ; * SHL AX,1
B $08,$D1,$E0,$8B,$C8 ; * MOV CX,AX
B $D1,$E0,$03,$C1 ; * SHL AX,1
JMP.b iacsend ; '* ADD AX,CX
iacs CALL emovcxi ; * MOV CX,#compo_size
CALL ecode
B $02,$F7,$E1 ; * MUL CX
iacsend CMP.B indflg,#$00 ; already indexed ?
JZ ianotind ; :no
CALL ecode ; add to previous index
B $02,$03,$F8 ; * ADD DI,AX
JMP.b iaind ; '
ianotindCALL ecode
B $01,$97 ; * XCHG DI,AX
MOV.B indflg,#$FF ; flag: indexed
iaind CMP.B varctp,#$01 ; component type = array ?
JNZ iaend ; no: end it
CALL ccomma ; , ?
JNZ iaend ; no: end it
JMP ialoop ; 'get next index
iaend CALL esqr2 ; ! ]
XOR AX,AX ; ok
RET ; "
indrec CMP.B varctp,#$02 ; Do record indexing
JNZ irret ; no record: ret
CALL cdot ; . ?
JNZ irret ; no: ret
MOV.B CL,varnest ; record nesting level
MOV CH,#$04 ; var
CALL search ; search subvar
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
iraddofsPUSH indptflg ; save base parms
PUSH varofs
CALL getvprm ; get var parms
POP AX ; restore offset
ADD varofs,AX ; add to new offset
POP indptflg ; restore indirection ptr
XOR AX,AX ; ok
irret RET ; "
indptr CMP.B varctp,#$04 ; Do pointer indexing
JNZ iptret ; no pointer: ret
CALL cptr ; ^ ?
JNZ iptret ; no: ret
MOV BP,lower ; type ptr
CALL getvprm2 ; get type parms
indptrldMOV DX,#$38C4 ; * LES DI,pointer_var
CALL einstr ; emit instruction
MOV varofs,#$0000 ; offset = 0
MOV.B varseg,#$FD ; segment = ES
MOV.B indflg,#$FF ; indexed
XOR AX,AX ; ok
iptret RET ; "
einstr MOV AL,varseg ; Emit instruction with addressing
CMP AL,#$FD ; ES ?
JB eistk ; :stack segment
CALL esegment ; emit segment prefix
CMP.B indflg,#$00 ; indexed ?
JNZ eiind ; :yes
MOV CH,#$06 ; mode: direct
OR.B DH,CH
CALL emitdx ; emit DX
MOV AX,varofs ; get offset
CALL eword ; emit offset
JMP.b eiret ; 'ret
eiind MOV AX,varofs ; get offset
OR AX,AX ; test offset
MOV CH,#$05 ; [DI]
JZ eiindofs ; :yes
CALL offslen ; short or long offset ?
MOV CH,#$45 ; short
JZ eiindofs ; :ok
MOV CH,#$85 ; long offset
eiindofsOR.B DH,CH ; set addressing mode
CALL emitdx ; emit opcode
TEST.B DH,#$C0 ; offset ?
JZ eiret ; no: ret
JMP.b eioffs ; 'emit offset
eistk CMP.B AL,lexnest ; in current procedure ?
MOV CX,#$0306 ; [BP]offs / [BP+DI]offs
JZ eistk2 ; :yes
CALL ecode ; * MOV BX,[BP]lex_level
B $02,$8B,$5E ; (get ptr from display)
ADD.B AL,AL ; - nesting level * 2
NEG.B AL
CALL ebyte ; emit offset
MOV AL,#$36 ; * SS:
CALL ebyte
MOV CX,#$0107 ; [BX]offs / [BX+DI]offs
eistk2 CMP.B indflg,#$00 ; indexed ?
JZ eistk3 ; :no
MOV.B CL,CH ; use [B.+DI]
eistk3 MOV AX,varofs ; get offset
CALL offslen ; short or long ?
MOV CH,#$40 ; short
JZ eistksh ; :ok
MOV CH,#$80 ; long
eistksh OR.B DH,CL ; set addressing mode
OR.B DH,CH
CALL emitdx ; emit opcode
eioffs MOV AX,varofs ; get offset
TEST.B DH,#$40 ; long ?
JNZ eioffbyt ; :no
CALL eword ; emit word offset
JMP.b eiret ; '
eioffbytCALL ebyte ; emit byte offset
eiret RET ; "
offslen OR.B AL,AL ; Short or long offset ?
JS offneg ; :negative
OR.B AH,AH ; high byte must be zero
RET ; '
offneg CMP.B AH,#$FF ; high byte must be FF
RET ; "
esegmentCMP.B varseg,#$FF ; emit segment prefix
JZ eseges ; DS:no prefix needed
CMP.B varseg,#$FD ; ES ?
MOV AL,#$26 ; (ES:)
JZ esegret ; :yes
MOV AL,#$2E ; (CS:)
esegret CALL ebyte ; emit prefix
eseges RET ; "
loadoffsCMP.B varseg,#$FD ; Get offset
JB ldostk ; :stack segment
MOV AX,varofs ; var offset
CMP.B indflg,#$00 ; indexed ?
JNZ ldoind ; :yes
JMP emovdii ; '* MOV DI,#offset
ldoind OR AX,AX ; test offset
JZ eseges ; 0:ret
CALL offslen ; short or long offset ?
MOV DX,#$C783 ; (ADD DI,#byte)
JZ ldobyt ; :short
MOV DL,#$81 ; (ADD DI,#word)
ldobyt PUSH AX ; save offset
CALL emitdx ; emit operation
POP AX ; offset
TEST.B DL,#$02 ; short ?
JZ ldoword ; :no
JMP ebyte ; 'emit byte offset
ldoword JMP eword ; 'emit word offset
ldostk MOV DX,#$388D ; (LEA DI,..)
JMP einstr ; "get effective addr -> DI
varptr CALL rdvar ; Get var ptr: get var
CALL errnz ; not found:
B $29 ; 41:Unknown ID or syntax error
varptr2 CALL loadoffs ; get offset -> DI
MOV AL,#$1E ; (PUSH DS) push offset
CMP.B varseg,#$FF ; DS ?
JZ varptret ; :yes
MOV AL,#$06 ; (PUSH ES)
CMP.B varseg,#$FD ; ES ?
JZ varptret ; :yes
MOV AL,#$16 ; (PUSH SS)
JB varptret ; :yes
MOV AL,#$0E ; (PUSH CS)
varptretJMP ebyte ; "emit op
eload CMP.B varctp,#$0A ; Load var
JB eldptr ; :no scalar
CMP.B varseg,#$FD ; ES ?
JB eldstk ; :SS: no shortcuts
CMP.B indflg,#$00 ; indexed ?
JZ elddir ; :no
eldstk MOV DL,#$8B ; (MOV)
CMP varsize,#$01 ; byte ?
JA eldword ; :no
MOV DL,#$8A ; (MOVB)
eldword MOV DH,#$00 ; MOV AX,...
CALL einstr ; emit instruction
JMP.b eldpbyt ; 'byte: clr hi byte
elddir CALL esegment ; emit segment prefix
MOV AL,#$A1 ; (MOV AX,var)
CMP varsize,#$01 ; byte ?
JA elddbyt ; :no
MOV AL,#$A0 ; (MOVB AL,var)
elddbyt CALL ebyte ; emit operation
MOV AX,varofs ; emit offset
CALL eword
eldpbyt CMP varsize,#$01 ; byte ?
JA eldret ; :no
CALL ecode
B $02,$32,$E4 ; * XOR AL,AL
eldret RET ; '
eldptr CMP.B varctp,#$04 ; load other types
JNZ eldreal ; :no ptr
MOV DX,#$00C4 ; LES AX,ptr_var
CALL einstr ; emit instruction
CALL ecode
B $02,$8C,$C2 ; * MOV DX,ES
RET ; '
eldreal CALL varptr2 ; get ptr -> DI,stack
MOV AX,#xldreal ; (load real)
CMP.B varctp,#$09 ; real ?
JZ eldemit ; :yes
MOV AX,#strload ; (load string)
CMP.B varctp,#$08 ; string ?
JZ eldemit ; :yes
CALL esetfac ; emit set crunch factor
MOV AX,#xldset ; (load set)
eldemit JMP ecall ; "emit call
estore CALL erngchk ; Store var: emit range check
estore2 CMP.B varctp,#$0A ; scalar ?
JB estcpl ; :no
eststo CMP.B varseg,#$FD ; SS ?
JB eststk ; yes: no shortcuts
CMP.B indflg,#$00 ; indexed ?
JZ estdir ; no: optimize
eststk MOV DL,#$89 ; (MOV dest_var,AX)
CMP varsize,#$01 ; byte ?
JA estword ; :no
MOV DL,#$88 ; (MOVB dest_var,AL)
estword MOV DH,#$00 ; mode
JMP einstr ; 'emit instruction
estdir CALL esegment ; emit segment prefix
MOV AL,#$A3 ; (MOV var,AX)
CMP varsize,#$01 ; byte ?
JA estdbyt ; :no
MOV AL,#$A2 ; (MOVB var,AL)
estdbyt CALL ebyte ; emit opcode
MOV AX,varofs ; emit var offset
JMP eword ; '
estptr CALL eststo ; store ptr: emit store AX
ADD varofs,#$02 ; offs second word
MOV DX,#$1089 ; emit store DX
JMP einstr ; 'emit instruction
estcpl CMP.B varctp,#$04 ; pointer ?
JZ estptr ; :yes
MOV AX,#xstoreal ; (store real)
CMP.B varctp,#$09 ; real ?
JZ estemit ; :yes
CMP.B varctp,#$08 ; string ?
JNZ estset ; :no
MOV.B AH,varsize ; get string length
DEC.B AH
MOV AL,#$B1
CALL eword ; * MOV CL,max_len
MOV AX,#strstore ; (store string)
JMP.b estemit ; 'emit call
estset CALL esetfac ; set crunch factor
MOV AX,#setsto ; (store set)
estemit JMP ecall ; "emit call
esetfac MOV BP,lower ; calculate set crunch factor
CALL getparm ; get parms of base type
MOV AL,varsize ; component size
MOV.B AH,lower2 ; lower bound/8
MOV CL,#$03
SHR.B AH,CL
JMP emovcxi ; "* MOV CX,#crunch
erngchk CMP.B varctp,#$0A ; Emit range check
JB erngret ; no scalar: ret
TEST direcsv,#$0002 ; range checking on ?
JZ erngret ; :no
MOV AX,lower ; lower bound-1 = upper bound ?
DEC AX
CMP AX,upper
JZ erngret ; yes: no check
INC AX ; restore lower
CALL emovcxi ; * MOV CX,#lower_bound
MOV AX,upper ; upper bound
CALL emovdxi ; * MOV DX,#upper_bound
MOV AX,#xrngchk ; (range check)
CALL ecall ; emit call
erngret RET ; "
rdnumcn CALL rdconst ; read numeric constant
snerror CALL errnz ; no good:
B $29 ; 41:Unknown ID or syntax error
RET ; "
rdintcn CALL rdnumcn ; get integer constant
testint CMP.B CL,#$0A ; integer ?
CALL errnz ; no:
B $16 ; 22:Integer constant expected
RET ; "
rdstrcn CALL rdnumcn ; get string constant
CMP.B CL,#$08 ; string ?
JZ rdstrret ; yes: ok
CMP.B CL,#$0C ; char ?
CALL errnz ; no:
B $20 ; 32:String constant expected
MOV CL,#$08 ; convert to string
rdstrretRET ; "
rdconst CALL testsign ; Read constant: test sign
PUSH DX ; save it
CALL constel ; get constant element
POP DX ; restore sign
JZ donegate ; :ok
OR DX,DX ; didn't work
CALL errnz ; 25:Int or real const expected
B $19
DEC DX ; ok
rdcnret RET ; '
donegateCALL testnum ; test type
JZ rdcnret ; :ret - no negation
CMP.B CL,#$09 ; real ?
JNZ rdcnnegi ; :no
CMP.B creal1,#$00 ; 0 ?
JZ rdcnok ; yes: don't negate
XOR.B cresign,#$80 ; negate it
JMP.b rdcnok ; 'ok
rdcnnegiNEG BX ; negate result
rdcnok XOR DX,DX ; ok
RET ; "
testsignMOV DI,chptr ; Test sign:test char
MOV DX,#$FFFF ; flag: negative
CMP.B [DI],#$2D ; - ?
JZ tsminus ; :yes
INC DX ; clear neg flag
CMP.B [DI],#$2B ; + ?
JNZ tsret ; no: don't skip char
INC DX ; set + flag
tsminus INC DI ; skip that char
CALL skipdi ; read next word
tsret RET ; "
testnum OR DX,DX ; Test type
JZ tnret ; :no negation - ok
CMP.B CL,#$0A ; integer ?
JZ tndec ; :ok
CMP.B CL,#$09 ; real ?
CALL errnz ; no:
B $19 ; 25:Int or real constant expected
tndec DEC DX ; clear plus flag
tnret RET ; "
constel CALL immecn ; Get const element: immediate const
JNZ clconst ; :no
RET ; '
clconst MOV CX,#$0200 ; search constant
CALL search
JNZ clret ; :not found
MOV.B CL,[BP]-$01 ; get component type
CMP.B CL,#$0A ; scalar ?
JB clreal ; :no
MOV BX,[BP]-$03 ; get value
JMP.b clok ; 'ok
clreal CMP.B CL,#$09 ; real ?
JNZ clstring ; :no
MOV AX,[BP]-$07 ; get real const
MOV creal1,AX ; store in buffer
MOV AX,[BP]-$05
MOV creal2,AX
MOV AX,[BP]-$03
MOV creal3,AX
JMP.b clok ; 'ok
clstringMOV.B CH,[BP]-$02 ; string: get length
MOV.B DL,CH
MOV BX,#wordbuf ; dest buffer
clstrlp OR.B DL,DL ; test len
JZ clok ; :done
DEC BP ; stored backwards !
MOV.B AL,[BP]-$02 ; get char
MOV.B [BX],AL ; copy into buffer
INC BX ; next pos
DEC.B DL ; another char ?
JMP clstrlp ; '
clok XOR DX,DX ; ok
clret RET ; "
immecn MOV DI,chptr ; get immediate constant
MOV.B AL,[DI] ; current char
CMP AL,#$27 ; ' ?
JZ icstr ; yes: string const
CMP AL,#$5E ; ^ ?
JZ icstr ; yes: string const
CMP AL,#$23 ; # ?
JNZ icnum ; no: numeric const
icstr MOV BX,#wordbuf ; dest buffer
MOV CH,#$00 ; length = 0
icsloop MOV.B AL,[DI] ; current char
CMP AL,#$5E ; ^ ?
JZ icscntrl ; :yes
CMP AL,#$23 ; # ?
JZ icsnum ; :yes
CMP AL,#$27 ; ' ?
JNZ icsend ; no: end of string const
icslp2 INC DI ; next char
MOV.B AL,[DI] ; get char
OR.B AL,AL ; line end ?
CALL perrz ; yes:
B $37 ; 55:String constant exceeds line
CMP AL,#$27 ; ' ?
JNZ icssto ; :no
INC DI ; test next char: may be ''
CMP.B [DI],#$27 ; ' ?
JNZ icsloop ; no: end of string
icssto MOV.B [BX],AL ; store in buffer
INC BX ; next pos
INC.B CH ; count length
JMP icslp2 ; 'continue
icscntrlINC DI ; next char: do ^char
MOV.B AL,[DI] ; get it
CALL upcase ; UpCase
OR.B AL,AL ; 0 ?
CALL perrz ; yes:
B $37 ; 55:String constant exceeds line
XOR AL,#$40 ; make it a control char
INC DI ; next char
icssto2 MOV.B [BX],AL ; store in buffer
INC BX
INC.B CH ; count length
JMP icsloop ; 'get next element
icsnum INC DI ; read #char
PUSH BX ; save dest ptr, counter
PUSH CX
MOV BX,DI ; pos of number
CALL asccard ; read integer
MOV DI,BX ; set new position
POP CX ; restore
POP BX
CALL perrb ; error:
B $38 ; 56:Error in int constant
JMP icssto2 ; 'store it, continue
icsend MOV CL,#$08 ; string
CMP.B CH,#$01 ; length = 1 ?
JNZ icend ; :no
MOV.B BL,wordbuf ; get char
XOR.B BH,BH ; clear high byte
MOV CL,#$0C ; char
icend JMP skipdi ; 'get next word
icnum MOV BX,DI ; numeric constant: beg pos
CMP AL,#$24 ; $ ?
JZ icnint ; yes: integer constant
CALL number ; char in 0..9 ?
JNB icnscan ; :yes
XOR AX,AX ; set flag: invalid
DEC AX
RET ; '
icnscan INC DI ; next char
MOV.B AL,[DI] ; get it
CALL number ; in 0..9 ?
JNB icnscan ; yes: loop
CALL upcase ; UpCase
CMP AL,#$45 ; E ?
JZ icnreal ; yes: real constant
CMP AL,#$2E ; . ?
JNZ icnint ; no: integer constant
INC DI ; test next char: .. ?
MOV.B AL,[DI]
CMP AL,#$2E ; . ?
JZ icnint ; :yes, integer constant
CMP AL,#$29 ; ) ? (.) = ])
JZ icnint ; yes: integer constant
icnreal MOV DI,#creal1 ; dest buffer
CALL ascreal2 ; read real number
MOV DI,BX ; set new position
CALL perrb ; error:
B $39 ; 57:Error in real const
MOV CL,#$09 ; real
JMP icend ; 'end it
icnint CALL asccard ; read integer const
MOV DI,BX ; set new pos
MOV BX,AX ; get result
CALL perrb ; ok ? no:
B $38 ; 56:Error in integer constant
MOV CL,#$0A ; integer
JMP icend ; "end it
ecode PUSH AX ; Emit inline code
PUSH BP ; (stored as inline string)
MOV BP,SP ; stack frame
XCHG BX,[BP]$04 ; get return addr
CS:
MOV.B AH,[BX] ; get length
INC BX ; next byte
ecodelp CS: ; get byte
MOV.B AL,[BX]
CALL ebyte ; emit it
INC BX ; next one
DEC.B AH
JNZ ecodelp ; :another
XCHG BX,[BP]$04 ; restore ret, BX
POP BP ; restore
POP AX
RET ; "
estring MOV.B AL,CH ; Emit string, CH=length
CALL ebyte ; emit length
estr2 MOV BX,#wordbuf ; buffer ptr
estrlp OR.B CH,CH ; test length
JZ estrret ; :null string
MOV.B AL,[BX] ; get char
CALL ebyte ; emit it
INC BX ; next one
DEC.B CH
JMP estrlp ; '
estrret RET ; "
epushax CALL ecode ; * PUSH AX
B $01,$50
RET ; "
epopax CALL ecode ; * POP AX
B $01,$58
RET ; "
epushdi CALL ecode ; * PUSH DI
B $01,$57
RET ; "
emovaxi CALL ecode ; * MOV AX,#..
B $01,$B8
JMP.b eword ; "emit immediate value in AX
CALL ecode ; * MOV BX,#..
B $01,$BB
JMP.b eword ; "emit immediate
emovcxi CALL ecode ; * MOV CX,#..
B $01,$B9
JMP.b eword ; "emit immediate
emovdxi CALL ecode ; * MOV DX,#..
B $01,$BA
JMP.b eword ; "emit immediate
emovdii CALL ecode ; * MOV DI,#..
B $01,$BF
JMP.b eword ; "emit immediate
ecall CALL ecode ; * CALL ..
B $01,$E8
JMP.b ejmp2 ; 'emit offset
ejump CALL ecode ; * JMP ..
B $01,$E9
ejmp2 SUB AX,pc ; dest-PC-2 -> offset
DEC AX
DEC AX
JMP.b eword ; "emit offset word
emitdx MOV AX,DX ; emit DX
eword CALL ebyte ; emit AX
PUSH AX ; save it
MOV.B AL,AH ; emit high byte
CALL ebyte ; emit byte
POP AX ; restore
RET ; "
ebyte CMP.B flgpshax,#$00 ; Emit byte in AL
JZ ebes ; :no PUSH AX
PUSH AX ; save
MOV AL,#$50 ; * PUSH AX
CALL ebemit
POP AX
MOV.B flgpshax,#$00 ; reset flag
ebes CMP.B flgpshes,#$00 ; emit PUSH ES ?
JZ ebdi ; :no
PUSH AX ; save
MOV AL,#$06 ; * PUSH ES
CALL ebemit
POP AX ; restore
MOV.B flgpshes,#$00 ; reset flag
ebdi CMP.B flgpshdi,#$00 ; emit PUSH DI ?
JZ ebemit ; :no
PUSH AX ; save
MOV AL,#$57 ; * PUSH DI
CALL ebemit
POP AX ; restore
MOV.B flgpshdi,#$00 ; reset flag
ebemit PUSH BX ; save
CMP.B cpmode,#$01 ; find runtime error ?
JZ ebfind ; :yes
MOV BX,cdptr ; code ptr-code pos of buffer
SUB BX,cdbufpt
ADD BX,cdbegpt ; + beg of code buffer
MOV ES,destseg ; dest segment
ES:
MOV.B [BX],AL ; store byte
JMP.b ebend ; '
ebfind MOV BX,pc ; PC = error pos ?
CMP BX,errpos2
JZ ebfound ; :yes - found !
ebend INC cdptr ; inc code pointers
INC pc
MOV BX,pc ; get PC
INC.B BH ; overflow ?
JZ eberr ; :yes
OR.B BL,BL ; 256 bytes done ?
JNZ ebnochk ; :no
CALL chkovrfl ; test for overflow
ebnochk POP BX ; restore BX
RET ; '
eberr CALL err ; 98:Memory overflow
B $62 ; '
ebfound CALL err ; C8:Error position found
B $C8 ; "
codflushCMP.B cpmode,#$02 ; Flush code buffer
JB cfret ; not to file:ret
MOV CX,cdptr ; code pointer
SUB CX,cdbufpt ; = code pos of buffer ?
STC
JZ cfret ; yes: nothing to flush
MOV AH,#$40 ; write byte block
MOV BX,dstfile ; dest file handle
MOV DX,cdbegpt ; beginning of code buffer
PUSH DS ; save DS
MOV DS,destseg ; dest segment
CALL dos ; write buffer
POP DS ; restore DS
JB cferr ; :error
CMP AX,CX ; length = expected ?
JZ cfok ; :yes
cferr CALL err ; C9:File error
B $C9 ; '
cfok MOV AX,cdptr ; code ptr -> code pos of buffer
MOV cdbufpt,AX
cfret RET ; "
ptcjmppcMOV AX,pc ; Patch jump address
ptcjmp SUB AX,BX ; dest (AX)-src (BX)-2
DEC AX
DEC AX
ptcjmp2 PUSH BX ; save dest
SUB BX,pc ; dest-PC+code ptr
ADD BX,cdptr
CALL patch ; patch it
POP BX ; restore
RET ; "
patch CMP.B cpmode,#$01 ; Patch word AX at pos BX
JZ ptret ; find error:ret
CMP BX,cdbufpt ; >= code pos of buffer ?
JB ptlist ; no: put it into patch list
PUSH BX ; save pos
SUB BX,cdbufpt ; -code pos of buffer
ADD BX,cdbegpt ; +beg of code buffer
MOV ES,destseg ; dest segment
ES:
MOV [BX],AX ; patch it in memory
POP BX ; restore
ptret RET ; '
ptlist PUSH CX ; save regs
PUSH DI ; patch list is sorted to
PUSH SI ; minimize disk accesses
PUSH SS ; SS -> ES
POP ES
MOV SI,ptcbeg ; start of patch list
MOV DI,ptctop ; top of patch list
ptsearchCMP SI,DI ; at the end ?
JZ ptstore ; yes: put it there
SS:
CMP BX,[SI] ; put it here ?
JB ptins ; :yes
ADD SI,#$04 ; go to next entry
JMP ptsearch ; 'continue searching
ptins MOV CX,DI ; calculate count to shift
SUB CX,SI
MOV SI,DI ; end position
ADD DI,#$04 ; -> end pos+4
DEC DI
DEC SI
PUSH DS ; save DS
PUSH SS ; SS -> DS
POP DS
STD ; make space for new entry
REPZ
MOVS.B
POP DS ; restore DS
INC SI ; point to dest pos
ptstore SS: ; store in patch list:
MOV [SI],BX ; address
SS:
MOV [SI]$02,AX ; value to be patched
ADD ptctop,#$04 ; add 4 to patch top
MOV CX,ptctop ; patch list top = end of
CMP CX,ptcend ; patch list space ?
JNZ ptnofl ; :no
CALL ptcflush ; flush patch list
ptnofl POP SI ; restore registers
POP DI
POP CX
RET ; "
ptcflushCMP.B cpmode,#$02 ; Patch code in file
JB ptfret ; no file - ret
PUSH AX ; save regs
PUSH BX
PUSH CX
PUSH DX
PUSH BP
MOV AX,#$4201 ; seek relative
MOV BX,dstfile ; dest file handle
XOR CX,CX ; get current pos in file
XOR DX,DX
CALL dos
PUSH AX ; save it
PUSH DX
MOV BP,ptcbeg ; start of patch list
ptflp CMP BP,ptctop ; end reached ?
JZ ptfend ; :yes
MOV AX,#$4200 ; seek absolute
MOV BX,dstfile ; dest file handle
MOV DX,cdfoff ; file offset
MOV CX,cdfoff1
ADD DX,[BP]$00 ; + patch addr
ADC CX,#$00 ; carry
CALL dos ; do seek
MOV AX,[BP]$02 ; get value to patch
MOV ptcbuf1,AX ; store in buffer
MOV AH,#$40 ; write patch value
MOV BX,dstfile ; dest file handle
MOV CX,#$0002 ; 2 bytes
MOV DX,#ptcbuf1 ; buffer ofs
CALL dos
CALL errb
B $C9 ; C):File error
ADD BP,#$04 ; next patch list entry
JMP ptflp ; '
ptfend MOV AX,ptcbeg ; clear patch list:
MOV ptctop,AX ; beg -> top
MOV AX,#$4200 ; seek absolute
MOV BX,dstfile ; dest file handle
POP CX ; restore current pos
POP DX
CALL dos ; set it again
POP BP ; restore regs
POP DX
POP CX
POP BX
POP AX
ptfret RET ; "
pushe2 MOV SI,#parm2 ; save entry 2 on stack
JMP.b pshe1 ; '
pushe1 MOV SI,#indflg ; save entry 1 on stack
pshe1 POP retbuf ; ret addr
MOV cxbuf,CX ; save CX
MOV CX,SS ; SS -> ES
MOV ES,CX
MOV CX,#$000F ; 15 bytes
SUB SP,CX ; make space on stack
MOV DI,SP ; dest: stack
CLD
REPZ
MOVS.B ; move it
psheend MOV CX,cxbuf ; restore CX
JMP [retbuf] ; "return
pope2 MOV DI,#parm2 ; restore entry 2 from stack
JMP.b pope ; '
pope1 MOV DI,#indflg ; restore entry 1 from stack
pope POP retbuf ; ret addr
MOV cxbuf,CX ; save CX
MOV SI,SP ; SP -> source
MOV CX,DS ; DS -> ES
MOV ES,CX
MOV CX,SS ; SS -> DS
MOV DS,CX
MOV CX,#$000F ; 15 bytes
CLD
REPZ
MOVS.B ; move it
MOV CX,ES ; restore DS
MOV DS,CX
MOV SP,SI ; remove entry from stack
JMP psheend ; "return
copye2 MOV DI,#parm2 ; copy entry 2 from stack
JMP.b cpe ; '
MOV DI,#indflg ; copy entry 1 from stack
cpe PUSH CX ; save CX
MOV SI,SP ; source: on stack
ADD SI,#$04 ; skip ret addr, CX
MOV CX,DS ; DS -> ES
MOV ES,CX
MOV CX,SS ; SS -> DS
MOV DS,CX
MOV CX,#$000F ; 15 bytes
CLD
REPZ
MOVS.B ; copy it
MOV CX,ES ; restore DS
MOV DS,CX
POP CX ; restore CX
RET ; "
symbyte MOV BP,symtop ; store AL in symtab
DEC BP ; down one byte
MOV.B [BP]$00,AL ; store it
MOV symtop,BP ; set new symtab top
RET ; "
symword MOV BP,symtop ; store AX in symtab
DEC BP ; down two bytes
DEC BP
MOV [BP]$00,AX ; store it
MOV symtop,BP ; set new symtab top
RET ; "
symoffs MOV AX,symtop2 ; Write symtab offset
SUB AX,symtop ; last entry-current+2
ADD AX,#$0002
CALL symword ; store offset
MOV AX,symtop ; symtab top ->
MOV symtop2,AX ; symtab top at beg of definition
JMP chkovrfl ; "test size
stotype MOV AX,#$0800 ; store type
CALL symword ; store tag: subtype
MOV AX,symtop ; symtab top
MOV vartp,AX ; -> type ptr
MOV BX,#parm1end ; source buffer
MOV BP,symtop ; destination
stotlp DEC BX ; go down
DEC BX ; write size, upper bound,
DEC BP ; lower bound, component type
DEC BP
MOV AX,[BX] ; get word
MOV [BP]$00,AX ; store it
CMP BX,#varctp ; end ?
JNZ stotlp ; :not yet
MOV symtop,BP ; set new top
CALL symoffs ; write offset
XOR AX,AX ; ok
RET ; "
getparm MOV BX,#maxsize ; Get var parms -> entry 2
JMP.b gvp2 ; '
getvprm MOV AX,[BP]-$06 ; Get var parms
MOV indptflg,AX ; var segment
MOV AX,[BP]-$04 ; var offset
MOV varofs,AX
MOV BP,[BP]-$02 ; type pointer
getvprm2MOV BX,#parm1end ; to entry 1
gvp2 PUSH CX ; save
MOV CX,#$0004 ; 8 bytes
gvplp DEC BP ; go down
DEC BP ; copy size, upper & lower bound,
DEC BX ; component type
DEC BX
MOV AX,[BP]$00 ; copy entry -> buffer
MOV [BX],AX
LOOP gvplp ; :another
POP CX ; restore
RET ; "
rdsymnewMOV AX,#$0100 ; 'Read symbol
JMP.b rsy1 ; 'no numbers, verify in symtab
rdsym0 MOV AX,#$0001 ; numbers allowed
JMP.b rsy1 ; '
rdsym XOR AX,AX ; no numbers
rsy1 PUSH AX ; save flag
CALL rdword ; read word
POP AX ; restore flag
OR.B AL,AL ; numbers allowed ?
MOV AL,wrdbuf1 ; first char ?
JZ rsynonum ; :no
CALL number ; 0..9 ?
JNB rsynum ; yes: ok
rsynonumCALL alpha ; valid char ?
CALL errb ; no:
B $3A ; 58:Illegal char in ID
rsynum OR.B AH,AH ; verify in symbol table ?
JNZ rsynotst ; :no
CALL dupvar ; test if duplicate
rsynotstCALL dupkey ; test if keyword
MOV BP,symtop ; destination
MOV.B BL,wordbuf ; word length
XOR.B BH,BH ; -> count
DEC BP ; go down
MOV.B [BP]$00,BL ; store length
rsysto DEC BP ; go down
MOV.B AL,[BX]wordbuf ; get char from buffer
MOV.B [BP]$00,AL ; store in symtab
DEC BX ; go back
JNZ rsysto ; :another char
MOV symtop,BP ; set new symtab top
rsynext MOV DI,wrdend ; go to end of word
JMP skipdi ; "get next word
rdword CMP.B wordflg,#$FF ; read word: word available ?
JNZ rdwret ; yes: ret
XOR BX,BX
MOV DI,chptr ; char ptr: source
MOV.B AL,[DI] ; get char
CALL alphanum ; char in alphanum ?
JB rdwother ; :no
rdwlp CMP.B BL,#$7F ; end of buffer ?
JZ rdwfull ; :yes - don't store
CMP AL,#$61 ; do UpCase
JB rdwupper ; :no
SUB AL,#$20
rdwupperINC BX ; go to next pos
MOV.B [BX]wordbuf,AL ; store char in buffer
rdwfull INC DI ; next char from source
MOV.B AL,[DI] ; get it
CALL alphanum ; in alphanum ?
JNB rdwlp ; yes: loop back
JMP.b rdwend ; 'no: end
rdwotherINC DI ; go to next pos
INC BX
MOV.B [BX]wordbuf,AL ; store char
MOV.B AL,[DI] ; next char
CMP AL,#$2E ; . ?
JZ rdwchar2 ; :yes
CMP AL,#$3D ; = ?
JZ rdwchar2 ; :yes
CMP AL,#$3E ; > ?
JNZ rdwend ; :no
rdwchar2INC DI ; store that char
INC BX
MOV.B [BX]wordbuf,AL
rdwend MOV.B wordbuf,BL ; store word length
MOV wrdend,DI ; store end addr of word
MOV.B wordflg,#$FE ; word available
rdwret RET ; "
search CALL srchall ; search whole symbol table
JNZ rdwret ; not found:ret
JMP skipdi ; "get next word
srchvar MOV BX,fence ; current var fence
JMP.b src1 ; '(BX=search limit)
srchall MOV BX,ptcbeg ; start of symtab
src1 MOV DX,CX ; type wanted
CMP.B DL,wordflg ; = type of current word ?
JZ srcsame ; :yes
PUSH BX ; save fence
CALL rdword ; read word
POP BX ; restore
MOV.B wordflg,DL ; store type wanted
CALL srchsym ; search in symbol table
JB srcnofnd ; :not found
MOV typept,AL ; store type returned
MOV sympos,BP ; store pos in symbol table
srcsame MOV BP,sympos ; get symtab pos
MOV DI,wrdend ; get end pos of word
MOV CX,DX ; type -> CX
CMP.B CH,typept ; compare type
RET ; '
srcnofndXOR AX,AX ; type returned: none
MOV typept,AL
DEC AX ; not found
RET ; "
srchsym MOV.B CL,wordbuf ; word length
XOR.B CH,CH ; -> count
MOV BP,symtop2 ; symtab position
PUSH SS ; SS -> ES
POP ES
CLD ; forward search
srchloopCMP BP,BX ; fence reached ?
JZ srsynf ; yes: not found
ADD BP,[BP]$00 ; add offset
MOV.B AL,[BP]-$01 ; get tag byte
OR.B AL,AL ; 0 ?
JZ srchloop ; yes: invisible entry
CMP AL,#$08 ; subtype ?
JZ srchloop ; yes: invisible
MOV AX,[BP]-$03 ; string length
CMP.B AL,CL ; = searched ?
JNZ srchloop ; :no
CMP.B AH,DL ; = wanted type ?
JNZ srchloop ; :no
MOV DI,BP ; calculate string position
SUB DI,#$03
SUB DI,CX ; - count
MOV SI,#wrdbuf1 ; word ptr
MOV AX,CX ; save count
REPZ ; do comparison
CMPS.B
XCHG AX,CX ; restore count
JNZ srchloop ; not the same: continue
MOV.B AL,[BP]-$01 ; get type
SUB BP,#$03 ; set ptr to beg of string
SUB BP,CX ; = beg of entry
CLC ; found !
RET ; '
srsynf STC ; not found
RET ; "
ckey CALL rdword ; check keyword: read word
POP BX ; return addr
CS:
MOV.B DL,[BX] ; get offset between words
CS:
MOV DI,[BX]$01 ; get pointer
ADD BX,#$03 ; skip inline parms
PUSH BX ; restore ret addr
ckey2 XOR.B DH,DH ; distance between keywords
MOV BX,#wordbuf ; word ptr
PUSH CS ; CS -> ES
POP ES
CLD ; forward search
ckloop CS:
MOV.B CL,[DI] ; get length
XOR.B CH,CH
JCXZ cknf ; nothing - end of list
INC CX ; -> count
MOV SI,BX ; source
REPZ
CMPS.B ; compare words
JZ ckfound ; :equal
ADD DI,CX ; add remaining count
ADD DI,DX ; add offset
JMP ckloop ; 'try next keyword
cknf DEC CX ; flag: not found
RET ; '
ckfound MOV BX,DI ; position in keyword table
CALL rsynext ; get next word
CS:
MOV AX,[BX] ; get word from keyword table
ckret RET ; "
ctoken CALL rdword ; Check keyword: read word
POP BX ; return address
CS:
MOV DI,[BX] ; inline parm: pointer
INC BX ; skip inline parm
INC BX
PUSH BX ; restore ret
MOV SI,#wordbuf ; word ptr
MOV.B CL,[SI] ; get length of keyword
XOR.B CH,CH ; -> count
INC CX
PUSH CS ; CS -> ES
POP ES
CLD ; compare words
REPZ
CMPS.B
JNZ ckret ; :not the same - ret
JMP rsynext ; "ok, get next word
dupkey MOV BX,#keytable ; new ID = keyword ?
dkloop CS: ; pointer: list of keyword areas
MOV.B DL,[BX] ; get offset
CMP.B DL,#$FF ; end of table ?
JZ dkret ; :yes
PUSH BX ; save pointer
CS:
MOV DI,[BX]$01 ; get pointer into table
CALL ckey2 ; check it
POP BX ; restore pointer
CALL errz ; yes:
B $35 ; 53:Reserved word
INC BX ; next entry
INC BX
INC BX
JMP dkloop ; 'do next one
dkret RET ; "
dupvar MOV BX,fence ; Duplicate ID ?
MOV.B DL,recnum ; expected type
CALL srchsym ; search in symbol table
JB dkret ; :ret
CALL err ; 43:Duplicate ID or label
B $2B ; "
csqr1 MOV DI,chptr ; Check [, (.
CMP.B [DI],#$5B ; [ ?
JZ chkskip ; yes: skip it
CMP.B [DI],#$28 ; ( ?
JNZ chkret ; no: ret
INC DI ; next char
CMP.B [DI],#$2E ; . ?
JMP.b chkcskip ; 'check it
csqr2 MOV DI,chptr ; Check ], .)
CMP.B [DI],#$5D ; ] ?
JZ chkskip ; yes: skip it
CMP.B [DI],#$2E ; . ?
JNZ chkret ; no: ret
INC DI ; next char
CMP.B [DI],#$29 ; ) ?
JMP.b chkcskip ; 'check it
ccolon MOV AL,#$3A ; : ?
JMP.b chkal ; 'check it
csemi MOV AL,#$3B ; semicolon ?
JMP.b chkal ; 'check it
ccomma MOV AL,#$2C ; , ?
JMP.b chkal ; 'check it
cdot MOV AL,#$2E ; . ?
JMP.b chkal ; 'check it
cbrack1 MOV AL,#$28 ; ( ?
JMP.b chkal ; 'check it
cbrack2 MOV AL,#$29 ; ) ?
JMP.b chkal ; 'check it
cequal MOV AL,#$3D ; = ?
JMP.b chkal ; 'check it
cptr MOV AL,#$5E ; ^ ?
chkal MOV DI,chptr ; current char = AL ?
CMP.B AL,[DI] ; compare
chkcskipJNZ chkret ; no: ret
chkskip INC DI ; skip it
JMP.b skipdi ; 'read next word
NOP
chkret RET ; "
esqr1 CALL csqr1 ; expect [: check [
CALL errnz ; no:
B $08 ; 8:[ expected
RET ; "
esqr2 CALL csqr2 ; expect ]: check ]
CALL errnz ; no:
B $09 ; 9:] expected
RET ; "
ecolon CALL ccolon ; expect :
CALL errnz ; no:
B $02 ; 2:':' expected
ecolret RET ; "
esemi CALL csemi ; expect semicolon
JZ ecolret ; yes: ret
esemierrCALL err ; 1:Semicolon expected
B $01 ; '
esemi2 CALL csemi ; expect semicolon
JZ ecolret ; yes: ret
CMP.B semiflg,#$00 ; flag set ?
JZ esemierr ; yes: error 1
CALL err ; 41:Unknown ID or syntax error
B $29 ; "
ecomma CALL ccomma ; expect ,
CALL errnz ; no:
B $03 ; 3:',' expected
RET ; "
ebrack1 CALL cbrack1 ; expect (
CALL errnz ; no:
B $04 ; 4:'(' expected
RET ; "
ebrack2 CALL cbrack2 ; expect )
CALL errnz ; no:
B $05 ; 5:')' expected
RET ; "
eequal CALL cequal ; expect =
CALL errnz ; no:
B $06 ; 6:'=' expected
RET ; "
eassign CALL ctoken ; expect :=
W tkassign ; check token
CALL errnz ; no:
B $07 ; 7:':=' expected
RET ; "
expof CALL ctoken ; expect OF
W tkof ; check token
CALL errnz ; no:
B $0F ; 15:OF expected
RET ; "
; This routine skips spaces until next word is reached.
skip MOV DI,chptr ; get next word: get char ptr
skipdi MOV.B semiflg,#$00 ; flag for semicolon error
MOV.B wordflg,#$FF ; search flag
skloop MOV AX,[DI] ; get char (two, actually)
CMP AL,#$20 ; space, control ?
JBE skspace ; yes: skip spaces
CMP AL,#$7B ; '{' ?
JZ skcom2 ; yes: comment
CMP AX,#$2A28 ; '(*' ?
JZ skcom ; yes: comment
MOV chptr,DI ; set char pointer
XOR AX,AX ; ok
RET ; '
skspace CALL getchar ; skip spaces: get char
JMP skloop ; 'loop back
skcom CALL getchar ; Comment: get char
skcom2 PUSH DX ; save
MOV.B DL,[DI] ; comment type
CMP.B [DI]$01,#$24 ; $ ?
JZ cdirec ; yes: compiler directive
skcomlp CALL getchar ; get char
skcom3 MOV AX,[DI] ; test two chars
CMP.B DL,#$2A ; '(*' ?
JNZ skcomcur ; :no
CMP AX,#$292A ; now '*)' ?
JNZ skcomlp ; no: loop back
CALL getchar ; end of comment - get char
JMP.b skcomend ; 'continue scanning
skcomcurCMP AL,#$7D ; '}' ?
JNZ skcomlp ; no: loop back
skcomendPOP DX ; restore
JMP skspace ; "continue scanning
cdirec PUSH BX ; Compiler directive: save regs
PUSH CX
PUSH DX
CALL getchar ; get char
cdlop CALL getchar ; get char
MOV.B AL,[DI] ; get directive
CALL upcase ; UpCase
CMP AL,#$49 ; I ? I/O-error handling, Include
MOV DX,#$0001 ; flag
JZ cdplus ; :yes +-
CMP AL,#$52 ; R ? Range checking
MOV DX,#$0002
JZ cdplus ; :yes +-
CMP AL,#$42 ; B ? I/O-mode (CON or TRM)
MOV DX,#$0004
JZ cdplus ; :yes +-
CMP AL,#$43 ; C ? Control C and S
MOV DX,#$0008
JZ cdplus ; :yes +-
CMP AL,#$55 ; U ? User Interrupt
MOV DX,#$0010
JZ cdplus ; :yes +-
CMP AL,#$4B ; K ? Stack check
MOV DX,#$0020
JZ cdplus ; :yes +-
CMP AL,#$56 ; V ? Type checking
MOV DX,#$0040
JZ cdplus ; :yes +-
CMP AL,#$44 ; D ? Device checking
MOV DX,#$0080
JZ cdplus ; :yes +-
CMP AL,#$47 ; G ? Input file buffer size
MOV BX,#cinpsize ; dest var: buffer size
JZ cdnum ; :yes #
CMP AL,#$50 ; P ? Output file buffer size
MOV BX,#coutsize ; dest var: buffer size
JZ cdnum ; :yes #
CMP AL,#$46 ; F ? Max number open files
MOV BX,#cmaxfil ; dest var: max files
JZ cdnum ; :yes #
XOR DX,DX ; no flag
CMP AL,#$41 ; A ? Absolute code
JZ cdplus ; :yes +-
CMP AL,#$57 ; W ? WITH nesting
JZ cdignore ; :yes #
CMP AL,#$58 ; X ? Array optimization
JZ cdplus ; :yes +-
CMP AL,#$4F ; O ?
JZ cdignore ; :yes #
cderr CALL perr ; remember pos
B $5D ; '93:Invalid compiler directive
cdend POP DX ; restore regs
POP CX
POP BX
JMP skcom3 ; 'continue scanning comment
cdplus CALL getchar ; +/- directive: get char
MOV.B AL,[DI] ; read it
XOR CX,CX ; clear flag
CMP AL,#$2B ; '+' ?
JZ cdset ; :yes
DEC CX ; set flag
CMP AL,#$2D ; '-' ?
JZ cdset ; :yes
CMP DX,#$01 ; include ?
JZ cdinclsk ; yes: do it
JMP cderr ; 'Invalid compiler directive
cdset MOV AX,direct ; old directives
XOR AX,CX ; invert if reset bit
OR AX,DX ; set / reset bit
XOR AX,CX ; invert if reset bit
MOV direct,AX ; set new directive
CALL getchar ; get char
cdnext MOV.B AL,[DI] ; ',' ?
CMP AL,#$2C
JNZ cdend ; no: end directive
JMP cdlop ; 'yes: loop back
cdignoreCALL getchar ; Ignore directive: get char
MOV.B AL,[DI]
CALL alphanum ; valid char ?
JNB cdignore ; yes: continue
JMP cdnext ; 'another directive ?
cdnum CALL getchar ; Get number: get char
PUSH BX ; save dest ptr
MOV BX,DI ; position
CALL asccard ; read integer
MOV DI,BX ; new position
POP BX ; dest ptr
JB cderr ; :error
OR AX,AX ; 0 ?
JZ cderr ; yes: error
MOV [BX],AX ; store result
JMP cdnext ; 'another directive ?
cdinclskCMP.B [DI],#$20 ; Set include file: space ?
JNZ cdincl ; no: do it
CALL getchar ; get char
JMP cdinclsk ; 'skip spaces
cdincl CMP.B inclflg,#$00 ; include file active ?
CALL errnz ; yes:
B $60 ; 96:Illegal nesting of include files
MOV BX,DI ; position
CALL kpasext ; parse filename, default .PAS
PUSH BX ; save pos
MOV DI,#inclpn ; copy path name
CALL fnscdi ; -> include filename buffer
POP DI ; restore pos
MOV AX,#$3D00 ; open file
MOV DX,#inclpn ; name ptr
PUSH DS ; DS -> ES
POP ES
CALL dos ; open it
CALL errb ; 90:File not found
B $5A
MOV incfile,AX ; store file handle
MOV AX,direct ; save compiler directives
MOV direcin,AX
XOR AX,AX ; clear vars:
MOV bufpt,AX ; buffer ptr
MOV bufend,AX ; buffer end
MOV frelpos,AX ; relative pos in file
MOV.B inclflg,#$FF ; set include flag
CALL disline ; display line number
JMP cdend ; "restore regs, continue scanning
getchar MOV.B AL,[DI] ; Get char
INC DI ; go to next one
OR.B AL,AL ; end of line ?
JZ getln ; :yes
RET ; '
getln PUSH BX ; save regs
PUSH CX
PUSH DX
CMP.B srcend,#$00 ; last line ?
CALL perrnz ; yes:
B $5B ; 91:Unexpected end of source
INC lincnt ; count lines
MOV DI,#pnbuf ; destination: line buffer
MOV CX,#$007F ; up to 127 chars
CMP.B inclflg,#$00 ; from include file ?
JNZ fileline ; :yes
MOV BX,srcptr ; pointer into text
MOV srclnbeg,BX ; -> beginning of source line
memline MOV.B AL,[BX] ; get char
CMP AL,#$1A ; ^Z ?
JZ memeof ; yes: mark end of source
INC BX ; next char
CMP AL,#$0D ; CR ?
JZ memlf ; yes: end of line
MOV.B [DI],AL ; store in buffer
INC DI ; next pos
LOOP memline ; :another char
JMP.b memsto ; 'end it
memlf CMP.B [BX],#$0A ; LF ?
JNZ memsto ; no: forget it
INC BX ; yes: skip it
JMP.b memsto ; 'set new pos
memeof MOV srcend,AL ; set flag: end of source
memsto MOV srcptr,BX ; store new pos in buffer
JMP.b filesto ; 'mark end of line
filelineMOV BX,bufpt ; buffer pointer
MOV AX,frelpos ; relative pos in file
ADD AX,BX ; + buffer offset
SUB AX,bufend ; - buffer end
MOV srclnbg,AX ; -> pos of line begin
fileloopCALL getincl ; get char from include file
CMP AL,#$1A ; ^Z ?
JZ fileeof ; :yes, close include
INC BX ; next char
CMP AL,#$0D ; CR ?
JZ filelf ; yes: end of line
MOV.B [DI],AL ; store char in buffer
INC DI ; next pos
LOOP fileloop ; :another char
JMP.b filelf2 ; 'end it
filelf CALL getincl ; get char from include file
CMP AL,#$0A ; LF ?
JNZ filelf2 ; no: forget it
INC BX ; skip
filelf2 MOV bufpt,BX ; store buffer ptr
JMP.b filesto ; 'mark end of line
fileeof MOV.B inclflg,#$00 ; clear include flag
MOV AX,direcin ; restore directives to
MOV direct,AX ; state before include
MOV AH,#$3E ; close
MOV BX,incfile ; file handle
CALL dos
filesto MOV.B [DI],#$00 ; store a 0 at the end
MOV DI,#pnbuf ; go to beg of buffer
CALL disline1 ; display line number
POP DX ; restore regs
POP CX
POP BX
RET ; "
getincl CMP BX,bufend ; Get char from include file
JB ginend ; :not yet end of buffer
PUSH CX ; save
MOV AH,#$3F ; read byte block
MOV BX,incfile ; file handle
MOV CX,#$0080 ; 128 bytes
MOV DX,#inclbuf ; buffer ptr
MOV SI,#$0080 ; ?
CALL dos ; read buffer
POP CX ; restore
JNB ginok ; :ok
XOR AX,AX ; nothing read
ginok MOV BX,#inclbuf ; start of buffer
OR AX,AX ; anything read ?
JNZ ginnoeof ; :yes
MOV.B [BX],#$1A ; store ^Z
INC AX ; 1 char
ginnoeofADD frelpos,AX ; relative pos in file
ADD AX,BX ; pos of buffer end
MOV bufend,AX
ginend MOV.B AL,[BX] ; get char
RET ; "
disline1TEST.B lincnt,#$0F ; Display line number
JZ disline ; :once every 16 lines
RET ; '
disline PUSH AX ; save regs
PUSH BX
PUSH CX
PUSH DX
MOV AL,#$0D ; write CR
CALL conput
CMP.B inclflg,#$00 ; include ?
JZ dismem ; :no
MOV AL,#$49 ; I
JMP.b disincl ; '
dismem MOV AL,#$20 ; space
disincl CALL conput ; write it
MOV AL,#$20 ; write space
CALL conput
MOV AX,lincnt ; get line number
CALL knum1 ; display it
CALL xkeypres ; Keypressed
OR.B AL,AL ; test flag
JZ disret ; :no
CALL prints ; write string
B " *** Abort compilation",$00
CALL yorn ; Y or N ?
JZ disok ; no: continue
CALL err ; CA:Compilation aborted
B $CA ; '
disok MOV CX,#$0020 ; clear 32 bytes
disera CALL prints ; write BS space BS
B $08," ",$08,$00
LOOP disera ; :another
disret POP DX ; restore regs
POP CX
POP BX
POP AX
RET ; "
; *** Start of Tables ***
; Standard definitions
W $000E,$02FC
B "INTEGER",$07,$00,$03
W $000B,$0308
B "CHAR",$04,$00,$03
W $000B,$0314
B "REAL",$04,$00,$03
W $000E,$0320
B "BOOLEAN",$07,$00,$03
W $000B,$0338
B "BYTE",$04,$00,$03
W $000C,$0001
B $0B,"TRUE",$04,$00,$02
W $000D,$0000
B $0B,"FALSE",$05,$00,$02
W $000E,$7FFF
B $0A,"MAXINT",$06,$00,$02
W $000D,$0000
B $0A,"BLACK",$05,$00,$02
W $000C,$0001
B $0A,"BLUE",$04,$00,$02
B $0D,$00,$02,$00
B $0A,"GREEN",$05,$00,$02
W $000C,$0003
B $0A,"CYAN",$04,$00,$02
W $000B,$0004
B $0A,"RED",$03,$00,$02
W $000F,$0005
B $0A,"MAGENTA",$07,$00,$02
W $000D,$0006
B $0A,"BROWN",$05,$00,$02
W $0011,$0007
B $0A,"LIGHTGRAY",$09,$00,$02
W $0010,$0008
B $0A,"DARKGRAY",$08,$00,$02
W $0011,$0009
B $0A,"LIGHTBLUE",$09,$00,$02
W $0012,$000A
B $0A,"LIGHTGREEN",$0A,$00,$02
W $0011,$000B
B $0A,"LIGHTCYAN",$09,$00,$02
W $0010,$000C
B $0A,"LIGHTRED",$08,$00,$02
W $0014,$000D
B $0A,"LIGHTMAGENTA",$0C,$00,$02
W $000E,$000E
B $0A,"YELLOW",$06,$00,$02
W $000D,$000F
B $0A,"WHITE",$05,$00,$02
W $000D,$0010
B $0A,"BLINK",$05,$00,$02
W $000C,$0000
B $0A,"BW40",$04,$00,$02
W $000C,$0002
B $0A,"BW80",$04,$00,$02
W $000B,$0001
B $0A,"C40",$03,$00,$02
W $000B,$0003
B $0A,"C80",$03,$00,$02
W $000E
W $2182,$DAA2,$490F ; 3.1415926536E+00
B $09,"PI",$02,$00,$02
W $0011,$FF00
W conbufln
W $0338
B "BUFLEN",$06,$00,$04
W $0012,$FF00
W hptop
W $0344
B "HEAPPTR",$07,$00,$04
W $0011,$FF00
W stdout
W $032C
B "OUTPUT",$06,$00,$04
W $0010,$FF00
W stdin
W $032C
B "INPUT",$05,$00,$04
W $000E,$FF00
W filcon
W $032C
B "CON",$03,$00,$04
W $000E,$FF00
W filcon
W $032C
B "TRM",$03,$00,$04
W $000E,$FF00
W filkbd
W $032C
B "KBD",$03,$00,$04
W $000E,$FF00
W fillst
W $032C
B "LST",$03,$00,$04
W $000E,$FF00
W filaux
W $032C
B "AUX",$03,$00,$04
W $000E,$FF00
W filusr
W $032C
B "USR",$03,$00,$04
W $0011,$FF00
W cbreak
W $0320
B "CBREAK",$06,$00,$04
W $0013,$FF00
W vkbdstat
W $02FC
B "CONSTPTR",$08,$00,$04
W $0013,$FF00
W vkbdget
W $02FC
B "CONINPTR",$08,$00,$04
W $0014,$FF00
W vconput
W $02FC
B "CONOUTPTR",$09,$00,$04
W $0014,$FF00
W vprnput
W $02FC
B "LSTOUTPTR",$09,$00,$04
W $0014,$FF00
W vauxput
W $02FC
B "AUXOUTPTR",$09,$00,$04
W $0013,$FF00
W vauxget
W $02FC
B "AUXINPTR",$08,$00,$04
W $0014,$FF00
W vusrput
W $02FC
B "USROUTPTR",$09,$00,$04
W $0013,$FF00
W vusrget
W $02FC
B "USRINPTR",$08,$00,$04
W $0013,$FF00
W verror
W $02FC
B "ERRORPTR",$08,$00,$04 ; "
; Standard types
; link type lower upper size tag: invisible
B $0C,$00,$0A,$00,$00,$80, ; integer
B $0C,$00,$0C,$00,$00,$00, ; char
B $0C,$00,$09,$00,$00,$00, ; real
B $0C,$00,$0B,$00,$00,$00, ; boolean
B $0C,$00,$06,$00,$00,$00, ; text file
B $0C,$00,$0A,$00,$00,$00, ; byte
B $0C,$00,$04,$00,$00,$00, ; pointer
B $0C,$00,$08,$00,$00,$00, ; string
B $0C,$00,$00,$00,$00,$00, ; untyped file
B $0C,$00,$07,$00,$00,$00, ; "typed file
; Patch table to patch in pointers to type entries
; Offsets relative to 9277
varpatchW $0002,$0010,$001B,$0026,$0034,$01A0,$01B1,$01C3,$01D4
W $01E4,$01F2,$0200,$020E,$021C,$022A,$0249,$025C,$026F
W $0283,$0297,$02AB,$02BE,$02D2,$02E5,$0238
; "
keytableB $00 ; Pointers into keyword table
W tkprog ; (offset between entries, pointer)
B $01
W tklabel
B $02
W tkbegin
B $04
W tkto
B $05
W tkmul2
B $05
W tkadd2
B $02
W tkcmp2
B $FF ; "end of table
tkprog B $07,"PROGRAM" ; Keyword table
tkend B $03,"END"
tkforwrdB $07,"FORWARD"
tkext B $08,"EXTERNAL"
tkpackedB $06,"PACKED"
tkarray B $05,"ARRAY"
tkfile B $04,"FILE"
tkset B $03,"SET"
tkrec B $06,"RECORD"
tkstr B $06,"STRING"
tkof B $02,"OF"
tkabs B $08,"ABSOLUTE"
tkthen B $04,"THEN"
tkelse B $04,"ELSE"
tkdo B $02,"DO"
tkuntil B $05,"UNTIL"
tknot B $03,"NOT"
tknil B $03,"NIL",$00 ; '
tktext B $04,"TEXT" ; other reserved words
tk2dot B $02,".."
tkassignB $02,":=" ; '
tklabel B $05,"LABEL",$01 ; definition part
B $05,"CONST",$02 ; byte at the end = token
B $04,"TYPE",$03
tkvar B $03,"VAR",$04
B $05,"BEGIN",$08
tkover B $07,"OVERLAY",$07
tkproc B $09,"PROCEDURE",$05
B $08,"FUNCTION",$06,$00 ; '
tkbegin B $05,"BEGIN" ; program part
W block ; word = vector to compiler routine
B $02,"IF"
W if
B $05,"WHILE"
W while
B $06,"REPEAT"
W repeat
B $03,"FOR"
W for
tkcase B $04,"CASE"
W case
B $04,"GOTO"
W goto
B $04,"WITH"
W with
B $06,"INLINE"
W inline
B $00 ; '
tkto B $02,"TO" ; keywords used with FOR
B $7D,$41,$49,$00 ; JGE / INC CX / DEC CX
B $06,"DOWNTO"
B $7E,$49,$41,$08 ; JNG / DEC CX / INC CX
B $00 ; '
tkmem B $03,"MEM",$01 ; special arrays
B $04,"MEMW",$02 ; (not reserved)
B $00 ; '
; Code descriptors: parameters for the code generator
; +0:operation #
; +1:opcode immediate form
; +2:standard opcode
; +4:option bits
; 1:XCHG CX,AX needed
; 2:no immediate form available
; 4:no var form available
; 8:CWD needed
; " 10:XCHG DX,AX needed at end
tkmul B $01,"*" ; Multiplication ops
B $00,$00,$F7,$E9,$02 ; no imme, IMUL CX
B $01,"/"
B $01,$00,$00,$00,$00 ; real only !
tkmul2 B $03,"AND" ; AND AX,CX
B $02,$25,$23,$C1,$00
B $03,"MOD" ; IDIV CX
B $03,$00,$F7,$F9,$1B ; no imme, both XCHG, CWD
B $03,"DIV" ; IDIV CX
B $04,$00,$F7,$F9,$0B ; no imme, XCHG CX,AX, CWD
B $03,"SHL" ; SHL AX,CL
B $05,$00,$D3,$E0,$07 ; no imme, no var, XCHG CX,AX
B $03,"SHR" ; SHR AX,CL
B $06,$00,$D3,$E8,$07 ; no imme, no var, XCHG CX,AX
B $00 ; '
tkadd B $01,"+" ; Addition ops
B $00,$05,$03,$C1,$00 ; ADD AX,CX
B $01,"-" ; SUB AX,CX
B $01,$2D,$2B,$C1,$01 ; XCHG CX,AX
tkadd2 B $02,"OR" ; OR AX,CX
B $02,$0D,$0B,$C1,$00
B $03,"XOR" ; XOR AX,CX
B $03,$35,$33,$C1,$00
B $00 ; '
tkcmp B $01,"=" ; Comparison ops
B $00,$74 ; table offset, branch op: JZ
B $02,"<>"
B $08,$75 ; JNZ
B $02,">="
B $10,$7D ; JGE
B $02,"<="
B $18,$7E ; JNG
B $01,">"
B $20,$7F ; JG
B $01,"<"
B $28,$7C ; JL
tkcmp2 B $02,"IN"
B $FF,$00 ; special
B $00 ; '
cmpcode B $00,$3D,$3B,$C1,$01 ; "CMP AX,CX XCHG CX,AX
stdprocsB $07,"WRITELN" ; Standard procedures
W pwriteln ; vector to COMPILER routine
B $05,"WRITE"
W pwrite
B $06,"READLN"
W preadln
B $04,"READ"
W pread
B $06,"DELETE"
W pdelete
B $06,"INSERT"
W pinsert
B $06,"GOTOXY"
W pgotoxy
B $06,"ASSIGN"
W passign
B $05,"RESET"
W preset
B $07,"REWRITE"
W prewrite
B $06,"APPEND"
W pappend
B $05,"CLOSE"
W pclose
B $05,"ERASE"
W perase
B $06,"RENAME"
W prename
B $04,"SEEK"
W pseek
B $08,"LONGSEEK"
W pseek
B $03,"NEW"
W pnew
B $04,"MARK"
W pmark
B $07,"RELEASE"
W prelease
B $06,"GETMEM"
W pgetmem
B $07,"DISPOSE"
W pdispose
B $07,"FREEMEM"
W pfreemem
B $03,"STR"
W pstr
B $03,"VAL"
W pval
B $09,"BLOCKREAD"
W pblockrd
B $0A,"BLOCKWRITE"
W pblockwr
B $05,"CHDIR"
W pchdir
B $05,"MKDIR"
W pmkdir
B $05,"RMDIR"
W prmdir
B $06,"GETDIR"
W pgetdir
B $07,"OVRPATH"
W povrpath
B $09,"RANDOMIZE"
W prndmize
B $04,"MOVE"
W pmove
B $08,"FILLCHAR"
W pfillchr
B $04,"EXIT"
W pexit
B $04,"HALT"
W phalt
B $05,"PORTW"
W pportw
B $04,"PORT"
W pport
B $05,"FLUSH"
W pflush
B $08,"TRUNCATE"
W ptruncat
B $07,"EXECUTE"
W pexecute
B $05,"CHAIN"
W pchain
B $04,"INTR"
W pintr
B $05,"MSDOS"
W pmsdos
B $07,"CRTINIT"
W pcrtinit
B $07,"CRTEXIT"
W pcrtexit
B $06,"CLRSCR"
W pclrscr
B $06,"CLREOL"
W pclreol
B $09,"HIGHVIDEO"
W pnrmvid
B $09,"NORMVIDEO"
W pnrmvid
B $08,"LOWVIDEO"
W plowvid
B $07,"INSLINE"
W pinsline
B $07,"DELLINE"
W pdelline
B $05,"DELAY"
W pdelay
B $06,"WINDOW"
W pwindow
B $09,"TEXTCOLOR"
W ptextcol
B $0E,"TEXTBACKGROUND"
W ptextbg
B $0E,"GRAPHCOLORMODE"
W pgrcolmd
B $09,"GRAPHMODE"
W pgrmode
B $05,"HIRES"
W phires
B $08,"TEXTMODE"
W ptxtmode
B $0F,"GRAPHBACKGROUND"
W pgraphbg
B $07,"PALETTE"
W ppalette
B $0A,"HIRESCOLOR"
W phirscol
B $0B,"GRAPHWINDOW"
W pgrwind
B $04,"PLOT"
W pplot
B $04,"DRAW"
W pdraw
B $05,"SOUND"
W psound
B $07,"NOSOUND"
W pnosound
B $00 ; "
stdfuncsB $03,"CHR" ; Standard functions
W fchr ; vector to COMPILER routine
B $03,"ORD"
W ford
B $04,"COPY"
W fcopy
B $06,"LENGTH"
W flength
B $03,"POS"
W fpos
B $06,"CONCAT"
W fconcat
B $04,"SUCC"
W fsucc
B $04,"PRED"
W fpred
B $06,"UPCASE"
W fupcase
B $05,"TRUNC"
W ftrunc
B $05,"ROUND"
W fround
B $03,"ODD"
W fodd
B $03,"ABS"
W fabs
B $03,"SQR"
W fsqr
B $04,"SQRT"
W fsqrt
B $03,"SIN"
W fsin
B $03,"COS"
W fcos
B $06,"ARCTAN"
W farctan
B $02,"LN"
W fln
B $03,"EXP"
W fexp
B $06,"RANDOM"
W frandom
B $03,"INT"
W fint
B $04,"FRAC"
W ffrac
B $0A,"PARAMCOUNT"
W fparmcnt
B $08,"PARAMSTR"
W fparmstr
B $02,"LO"
W flo
B $02,"HI"
W fhi
B $04,"SWAP"
W fswap
B $08,"IORESULT"
W fiores
B $03,"EOF"
W feof
B $04,"EOLN"
W feoln
B $07,"SEEKEOF"
W fseekeof
B $08,"SEEKEOLN"
W fseekeol
B $08,"FILESIZE"
W ffilsize
B $0C,"LONGFILESIZE"
W flfilsiz
B $07,"FILEPOS"
W ffilpos
B $0B,"LONGFILEPOS"
W flfilpos
B $0A,"KEYPRESSED"
W fkeypres
B $08,"MAXAVAIL"
W fmaxavl
B $08,"MEMAVAIL"
W fmemavl
B $05,"PORTW"
W fportw
B $04,"PORT"
W fport
B $04,"ADDR"
W faddr
B $03,"PTR"
W fptr
B $03,"OFS"
W fofs
B $03,"SEG"
W fseg
B $06,"SIZEOF"
W fsizeof
tkdseg B $04,"DSEG"
W fdseg
tkcseg B $04,"CSEG"
W fcseg
B $04,"SSEG"
W fsseg
B $06,"WHEREX"
W fwherex
B $06,"WHEREY"
W fwherey ; "
; *** End of Turbo 3.0 ***
B $00
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment