;============================================================================= ; SCHEME SYSTEM BOOT LOADER boot28 2/3/92 ; ; includes: ; int #x90 low level error ; int #x91 string->symbol ; int #x92 stack-check ; int #x93 scheme function caller ; int #x94 scheme apply ; int #x95 primitive printer ; int #x96 heap space check ; calls garbage collector "%gc" if needed ; int #x97 heap allocation pointer update ; int #x98 closure allocator ; int #x99 box allocator ; int #x9a bignum allocator (not used) ; int #x9b list allocator ; int #x9c cons allocator ; int #x9d integer->real ; int #x9e call scheme "error" ; int #x9f low level error (for BCO that do not push CP & FP) ; int #xa0 exit to DOS ; int #xa1 DOS EXEC function ; ; int #x23 Ctrl C & Ctrl break handler ; int #x1B Ctrl break handler ; ;============================================================================= ; bound to globals: ; name value desc ; %write undefined primitive writer ; %load bound low level loader ; call/cc bound call/cc ; error undefined scheme error ; %gc undefined gabage collector ; args bound command line args ; dos-env bound DOS evironment when scheme started ; ;============================================================================= ; boot.loader appends files to this program and add to system function list ; address int global desc ;------------------------------------------------------------------ ; ss:110 #x96 %write primitive printer ; ss:114 %gc garbage collector ; ss:118 #x90 #x9f low level error handler ; ss:11c %load low level loader file < 64K ; ss:120 global symbol matcher ; ss:124 #x9d exact->inexact integer->real (takes any number) ; ;============================================================================= ; ; ((l boot.begin) ; address CS:100 (jmp) (dw boot.message) (nop) ; end address CS:104 ;-------------------------------------------------------- ; system variable table (base variables) ; these system variables can be accessed any time ; by using SS and an offset. ; (more system vars are at the top of stack) ;-------------------------------------------------------- (aw100 boot.end.init) ; boot end SS:104 (el boot.end #x104) (iw #x110) ; pointer to next function SS:106 (el boot.function #x106) 0 ; coproc type 0=none 1=87/287 2=387 SS:108 (el coproc.type #x108) 0 ; processor type 1=8088 2=286 3=386 4=486 (el proc.type #x109) 0 0 ; Expanded Memory Handle 0 if EM not used (el em.handle #x10a) 0 0 ; Number of Expanded 16K pages (el em.pages #x10c) 0 0 ; DOS env length (el env.length #x10e) ; ; system function table ; these funnction can be call by using the pointers in this table ; 0 0 0 0 ; primitive writer @ SS:110 (el prim.write #x110) 0 0 0 0 ; garbage collector @ SS:114 (el garbage.collect #x114) 0 0 0 0 ; error.handler @ SS:118 (el error.handler #x118) 0 0 0 0 ; %load low level loader @ SS:11c (el low.load #x11c) 0 0 0 0 ; global symbol matcher @ SS:120 (el gsm.function #x120) 0 0 0 0 ; integer->real @ SS:124 (el itor.function #x124) 0 0 0 0 ; DOS exec @ SS:128 (el dex #x128) ;-------------------------------------------------------- ; boot object loader ; load from the file named by string DS:AX ;-------------------------------------------------------- (l boot.loader) (xor ah ah) ; DS:BX = untagged to string (mov ax bx) (mov (bx db w) cx) 2 ; put string length in cx (add ib bx) 4 (mov bx dx) ; DS:DX = 1st char of string ; ; open file ; (mov iw ax) (iw #x3d40) (int #x21) (jae) 3 (jmp) (dw bootl.open.err) ; ; get size of file ; (mov ax bp) ; BP = file handle (mov iw ax) (iw #x4202) (mov bp bx) (xor cx cx) (xor dx dx) (int #x21) ; DX:AX = size of file (and dx dx) (jz) 3 (jmp) (dw bootl.size.err) (mov ax di) ; DI = size of file (mov iw ax) (iw #x4200) ; reset file pointer to beginning (mov bp bx) (xor cx cx) (xor dx dx) (int #x21) ; ; adjust boot size to hold file ; (ss:) (mov (dw w) dx) (aw boot.end) ; DX = current end to boot (add ib dx) 15 ; round DX to next paragraph (and iw dx) (iw #xfff0) (mov dx ax) ; AX = new boot end (add di ax) ; add file size DI (ss:) (mov ax (dw w)) (aw boot.end) ; save new boot end (add iw ax) (iw #x100) (cs:) (mov ax (dw w)) (aw100 stack.bottom) ; save new stack bottom ; ; setup pointer to function to be loaded ; (ss:) (mov (dw w) bx) (aw boot.function) ; current availible function (xor ax ax) ; save new function in table (cs:) (mov ax (bx w)) ; function calling address = (CS + DX/16):0000 (mov dx ax) (mov ib cl) 4 (shr cl ax) (mov cs cx) (add cx ax) (cs:) (mov ax (bx db w)) 2 (add ib bx) 4 (ss:) (mov bx (dw w)) (aw boot.function) ; update availible function ; ; read in the file handle = BP size = DI ; (mov cs ax) ; DS:DX = pointer to new space (mov ax ds) (mov iw ax) (iw #x3f00) (mov bp bx) (mov di cx) (int #x21) (jae) 3 (jmp) (dw bootl.read.err) ; ; Close File ; (mov iw ax) (IW #x3E00) (mov BP BX) (int #x21) ; (call) (dw ps.con) ; (ss ",") (ret) ; ; Error messages ; (l bootl.open.err) (mov sp bp) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: can not open boot load file") (l bootl.size.err) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: boot load file too big") (l bootl.read.err) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: problem reading boot load file") ;-------------------------------------------------------- ; boot messages ;-------------------------------------------------------- (l boot.message) (call) (dw ps.con) (ss 13 10 "Scheme-8088 Beta 0.28 (c) 1991,1992,1993 William Hunt & David Boyer" 13 10) (cs:) (mov (dw w) bx) (iw 2) ; get end of memory from DOS PSP (mov bx bp) ; BX = end (mov cs dx) ; DX = beginning (sub dx bp) ; BP = diff (jb) (db boot.err) (push bx) (push dx) (push bp) (call) (dw format) (ss "%kK memory availible from %kK to %kK" 13 10) (cmp iw bp) (iw 256) (jb) (db boot.err) (jmp) (dw boot.emm.ck) (l boot.err) (call) (dw ps.con) (ss "Not enough memory to load Scheme" 13 10) (mov iw ax) (iw #x4c00) ; never returns (go back to DOS) (int #x21) ;---------------------------------------------------------- ; check for Expanded Memory Manager device EMMXXXX0 ;---------------------------------------------------------- ; (() (l boot.emm.name) (ss "EMMXXXX0") (l boot.emm.ck) (mov cs ax) ; try to open EMMXXXX0 (mov ax ds) (mov iw dx) (aw100 boot.emm.name) (add ib dx) 4 (mov iw ax) (iw #x3d40) (int #x21) (jb) (db boot.no.emm) (mov ax bx) ; BX = handle (mov iw ax) (iw #x4400) (int #x21) (jb) (db boot.no.emmc) (and dl dl) ; check for device (js) (db boot.emm.ok) ; if bit 7 then device else file (l boot.no.emmc) (mov iw ax) (iw #x3e00) ; close file (int #x21) (l boot.no.emm) (call) (dw ps.con) (ss "No Expanded Memory Manager" 13 10) (jmp) (dw boot.device.ck) ; ; test EMS status ; (l boot.emm.err) (call) (dw ps.con) (ss 13 10 "Expanded Memory Manager ERROR" 13 10) (xor ax ax) ; zero Expanded Memory Handle (ss:) (mov ax (dw w)) (aw em.handle) (jmp) (dw boot.device.ck) (l boot.emm.ok) (mov iw ax) (iw #x3e00) ; close file (int #x21) (mov iw ax) (iw #x4000) ; check status (int #x67) (and ah ah) (jnz) (db boot.emm.err) (mov iw ax) (iw #x4600) ; CX = version (int #x67) (and ah ah) (jnz) (db boot.emm.err) (mov ax cx) (mov iw ax) (iw #x4200) ; BP = number page availible (int #x67) (and ah ah) (jnz) (db boot.emm.err) (mov bx bp) (push bp) (mov cx ax) (and ib al) #x0f (push ax) (mov cx ax) (and ib al) #xf0 (shr ax) (shr ax) (shr ax) (shr ax) (push ax) (call) (dw format) (ss "Expanded Memory Manager V%d.%d %d 16K pages availible ") ; ; check for enough pages heap semi-space ; ; (jmp) (dw boot.emm.not.used) ;************************* remove for emm gc (cs:) (mov (dw w) ax) (iw 2) ; get end of memory from DOS PSP (mov cs bx) (add iw bx) (iw #x1000) ; BX = heap beginning (sub bx ax) ; AX = heap size (add iw ax) (iw #x03ff) ; round size up to next 16K (mov ib cl) 10 (shr cl ax) ; AX = heap size in 16K pages (mov ax bx) ; BX = heap size in 16K pages (call) (dw print.dec) (cmp bx bp) ; are there enough pages? (jb) (db boot.emm.need) (call) (dw ps.con) (ss " 16K pages used" 13 10) (ss:) (mov bx (dw w)) (aw em.pages) ; save number of pages (mov iw ax) (iw #x4300) (int #x67) (and ah ah) (jz) 3 (jmp) (dw boot.emm.err) (ss:) (mov dx (dw w)) (aw em.handle) ; save Expanded Memory Handle (jmp) (dw boot.device.ck) (l boot.emm.not.used) (call) (dw ps.con) (ss " EMM GC not supported" 13 10) (jmp) (dw boot.device.ck) (l boot.emm.need) (call) (dw ps.con) (ss " 16K pages needed" 13 10) (jmp) (dw boot.device.ck) ;---------------------------------------------------------- ; test processor and co-processer type ;---------------------------------------------------------- (l boot.device.ck) ; test for 8088 (cli) (mov ib al) 1 (cs:) (mov al (dw b)) (aw100 boot.dm1) (nop) (nop) (mov ib al) (l boot.dm1) 0 (sti) (and al al) (jz) (db boot.dev2.ck) (mov ib al) 1 (cs:) (mov al (dw b)) (aw proc.type) (call) (dw ps.con) (ss "88/86/188/186 processor") (jmp) (dw boot.device.cpck) (l boot.dev2.ck) ; test for 486 (cli) (mov ib al) 1 (cs:) (mov al (dw b)) (aw100 boot.dm2) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (nop) (mov ib al) (l boot.dm2) 0 (sti) (and al al) (jnz) (db boot.dev23.ck) (mov ib al) 4 (cs:) (mov al (dw b)) (aw proc.type) (call) (dw ps.con) (ss "486 processor") (jmp) (dw boot.device.cpck) (l boot.dev23.ck) ; test for 286 or 386 (pushf) ; save flags (mov iw ax) (iw #xf000) ; try to set high flag bits (push ax) (popf) (pushf) (pop ax) (popf) ; restore flags (and iw ax) (iw #xf000) (jz) (db boot.dev2) (l boot.dev3) (mov ib al) 3 (cs:) (mov al (dw b)) (aw proc.type) (call) (dw ps.con) (ss "386 processor") (jmp) (dw boot.device.cpck) (l boot.dev2) (mov ib al) 3 (cs:) (mov al (dw b)) (aw proc.type) (call) (dw ps.con) (ss "286 processor") (jmp) (dw boot.device.cpck) ; ; coprocessor check ; .align-long (l boot.cpw) (iw #xffff) (l boot.cp0) #x55 #x55 #x55 #x55 #x55 #x55 #x55 #x55 #x55 #x55 ; ; coprocessor 1st check ; (l boot.device.cpck) ; (finit) ; (mov iw bx) (aw100 boot.cpw) ; (mov iw cx) (iw 10) ; wait for coproc ; (l boot.cp.l0) ; (loop) (db boot.cp.l0) ; (cs:) (fstcw (bx d)) ; get control word ; (mov iw cx) (iw 20) ; wait for coproc ; (l boot.cp.l1) ; (loop) (db boot.cp.l1) ; (cs:) (mov (bx w) ax) ; (inc ax) ; (jnz) (db boot.cp.ck2) (xor ax ax) ; no coprocessor (cs:) (mov al (dw b)) (aw coproc.type) (call) (dw ps.con) (ss " Not checking for coprocessor" 13 10) ; (ss " with no coprocessor" 13 10) (jmp) (dw boot.cp.end) ; ; coprocessor 2nd check ; (l boot.cp.ck2) (mov iw di) (aw100 boot.cp0) (fwait) (finit) (fwait) (fld1) (fwait) (cs:) (fstp.tr (di d)) (fwait) (nop) (cs:) (mov (di db w) ax) 8 ; check exponent (cmp iw ax) (iw #x3fff) (jnz) (db boot.?cp) (cs:) (mov (di db w) ax) 6 ; check man (cmp iw ax) (iw #x8000) (jz) (db boot.cp.type) (l boot.?cp) (xor ax ax) (cs:) (mov al (dw b)) (aw coproc.type) (call) (dw ps.con) (ss " with ??? coprocessor" 13 10) (jmp) (dw boot.cp.end) ; ; determine type of coprocessor ; (l boot.cp.type) (fwait) (finit) (fwait) (fldz) ; test for 87/287 or 387/486 (fwait) (fld1) (fwait) (fdiv.dpr s1) (fwait) (fld s0) (fwait) (fchs) (fwait) (fcompp) (fwait) (cs:) (fstsw (bx d)) (fwait) (nop) (cs:) (mov (bx w) ax) (sahf) (je) (db boot.cp2) (mov ib al) 2 (cs:) (mov al (dw b)) (aw coproc.type) (call) (dw ps.con) (ss " with 387/487 coprocessor" 13 10) (jmp) (dw boot.cp.end) (l boot.cp2) (mov ib al) 1 (cs:) (mov al (dw b)) (aw coproc.type) (call) (dw ps.con) (ss " with 87/287 coprocessor" 13 10) (l boot.cp.end) (jmp) (dw boot.int.setup) ;----------------------------------------------------------------------------- ; setup interupts ; int #x90 low level error handler ; int #x91 string->symbol global symbol table ; int #x92 stack-check ; int #x93 scheme function caller ; int #x94 Scheme function apply ; int #x95 primitive write "pwrite.o" ; int #x96 heap space check (calls gabarge collector "gc.o") ; int #x97 heap allocation pointer update ; int #x98 closure allocator ; int #x99 box allocator ; int #x9a bignum allocator (not used) ; int #x9b list allocator ; int #x9c cons allocator ; int #x9d integer->real ; int #x9e call scheme "error" ; int #x9f low level error (for BCO that do not push CP & FP) ; int #xa0 exit to DOS ; int #xa1 DOS EXEC function ; ; int #x23 Ctrl C & Ctrl break handler ; int #x1B Ctrl break handler ;----------------------------------------------------------------------------- ; (() ; ; 00ii ii=int number 0000:0000 holder for restoring xxxx int vector ; .align-para (l boot.int.table) (iw #x0090) (iw 0) (iw 0) (aw100 ll.error) (iw #x0091) (iw 0) (iw 0) (aw100 str->sym) (iw #x0092) (iw 0) (iw 0) (aw100 stack.check) (iw #x0093) (iw 0) (iw 0) (aw100 fun.call) (iw #x0094) (iw 0) (iw 0) (aw100 fun.apply) (iw #x0095) (iw 0) (iw 0) (aw100 print.int) (iw #x0096) (iw 0) (iw 0) (aw100 space.check) (iw #x0097) (iw 0) (iw 0) (aw100 alloc.update) (iw #x0098) (iw 0) (iw 0) (aw100 closure.alloc) (iw #x0099) (iw 0) (iw 0) (aw100 box.alloc) (iw #x009a) (iw 0) (iw 0) (aw100 bignum.alloc) (iw #x009b) (iw 0) (iw 0) (aw100 list.alloc) (iw #x009c) (iw 0) (iw 0) (aw100 cons.alloc) (iw #x009d) (iw 0) (iw 0) (aw100 int->real) (iw #x009e) (iw 0) (iw 0) (aw100 call.error) (iw #x009f) (iw 0) (iw 0) (aw100 ll.error.bco) (iw #x00a0) (iw 0) (iw 0) (aw100 exit.to.dos) (iw #x00a1) (iw 0) (iw 0) (aw100 dos.exec) (iw #x0023) (iw 0) (iw 0) (aw100 ctrl.cb) (iw #x001B) (iw 0) (iw 0) (aw100 ctrl.break) (el number.ints 20) (l boot.int.setup) ; ; setup interupts ; (mov cs ax) ; DS:SI = int table (mov ax ds) ; DS = CS (segment for all new vectors) (mov iw si) (aw100 boot.int.table) (mov iw cx) (aw number.ints) ; CX = number of ints (l int.loop) (cld) (mov (si w) ax) ; AX = int number (mov ib ah) #x35 ; get current vector (int #x21) (mov bx (si db w)) 2 ; save current vector (mov es (si db w)) 4 (mov (si db w) dx) 6 ; set vector for Scheme (add ib si) 8 (mov ib ah) #x25 (int #x21) (loop) (db int.loop) ;--------------------------------------------------------------- ; test for debug present ;--------------------------------------------------------------- (cs:) (mov (dw b) al) (aw coproc.type) (and al al) (jnz) (db mod.int3) (jmp) (dw stack.setup) (l int3.pat) #x55 #x8b #xec #xff #x8e #x02 #x00 #x5d #xeb #x1a (l mod.int3) (xor ax ax) ; DS = 0 (mov ax ds) ; DS:12 = int3 (mov (dw w) si) (iw 12) ; DS:SI = old int3 (mov (dw w) ds) (iw 14) (cmp iw si) (iw #x1182) ; vector for debug (jz) 3 (jmp) (dw stack.setup) (mov cs ax) ; ES:DI = debug pattern (mov ax es) (mov iw di) (aw100 int3.pat) (mov iw cx) (iw 10) (cmps.bz cx) (jz) 3 (jmp) (dw stack.setup) (call) (dw ps.con) (ss "DEBUG found and INT3 modified" 13 10) ;------------------------------------------------------------------- ; modify INT3 to include x87 debugger if coprocessor present ;------------------------------------------------------------------- ; CS:SI = pointer for "new int3" to jump to "old int3" (mov iw si) (aw100 old.int3) (mov iw ax) (iw #x11a6) (cs:) (mov ax (si db w)) 0 (cs:) (mov ds (si db w)) 2 (mov ds ax) ; ES:DI = old int3 (mov ax es) (mov iw di) (iw #x1182) (cld) (mov ib al) #xea ; jmpf (stos.b) (mov iw ax) (aw100 new.int3) ; new vector offset (stos.w) (mov cs ax) ; new vector segment (stos.w) ;----------------------------------------------------------------------------- ; setup Scheme and system stack ; Scheme system variable on top of stack: ; FFF8 heap allocation pointer ; FFF4 beginning of heap memory ; FFF0 end of heap memory ; FFEC current semi-space base (starts as beginning) ; FFE8 current semi-space end ; FFE4 new semi-space base (starts as half way) not used for EM ; FFE0 new semi-space end not used for EM ; FFDE critical area flag (no allocation allowed) ; FFDC break flag ^C or ^break ; FFD8 global symbol table vector ;----------------------------------------------------------------------------- ; (() ; ; adjust stack bottom limit for DOS safety margin ; (l stack.setup) (cs:) (mov (dw w) ax) (aw100 stack.bottom) (add iw ax) (iw #x100) (cs:) (mov ax (dw w)) (aw100 stack.bottom) ; ; (l setup.int) (xor ax ax) ; align stack to #xFFFC (push ax) ;-------------------------------------------------- ; heap allocation pointer: ; untagged pointer to next availible long word ; BX = beginning of heap, beginning of current ; CX = end of current semi-space, beginning of new ; DX = end of new semi-space ;-------------------------------------------------- (mov cs bx) ; setup free space start (heap start) (add iw bx) (iw #x1000) (xor ax ax) (push bx) ; heap allocation pointer @ SS:#xFFF8 (push ax) (el heap.seg #xfffa) (el heap.off #xfff8) (push bx) ; beginning of heap @ SS:FFF4 (push ax) (el heap.begin.seg #xfff6) (cs:) (mov (dw w) dx) (iw 2) ; get end of memory from DOS PSP (push dx) ; end of heap @ SS:FFF0 (push ax) (el heap.end.seg #xfff2) (ss:) (mov (dw w) ax) (aw em.handle) ; are we using Expanded Memory? (and ax ax) (jnz) (db stack.em) ;-------------------------------------------------- ; 2 semi-space in 640K memory ;-------------------------------------------------- (mov dx ax) ; AX = (end - beginning)/2 (sub bx ax) (shr ax) (mov bx cx) ; CX = beginning + AX (current end) (add ax cx) (mov bx dx) ; DX = beginning + AX + AX (new end) (add ax dx) (add ax dx) (xor ax ax) (push bx) ; current semi-space beginning @ SS:FFEC (push ax) (push cx) ; current semi-space end @ SS:FFE8 (push ax) (el cur.end.seg #xffea) (el cur.end.off #xffe8) (push cx) ; new semi-space beginning @ SS:FFE4 (push ax) (push dx) ; new semi-space end @ SS:FFE0 (push ax) (jmp) (dw stack.fs) ;-------------------------------------------------- ; 1 semi-space in 640K memory ; Copy space in Expanded Memory ;-------------------------------------------------- (l stack.em) (xor ax ax) (push bx) ; current semi-space beginning @ SS:FFEC (push ax) (push dx) ; current semi-space end @ SS:FFE8 (push ax) (push ax) ; new semi-space beginning @ SS:FFE4 is not used (push ax) (push ax) ; new semi-space end @ SS:FFE0 is not used (push ax) ;-------------------------------------------------- ; critical area and break flag ;-------------------------------------------------- (l stack.fs) (xor ax ax) (push ax) ; critical area flag (NO calls to GC) (xor ax ax) (push ax) ; break.flag ^C or ^break (el critical.f #xffde) (el break.flag #xffdc) ;-------------------------------------------------- ; global symbol table: #256( symlist0 symlist1 ... symlist255 ) ;-------------------------------------------------- (mov iw ax) (iw 66) ; no GC call (int #x96) ; ES:DI = alloc pointer (mov di dx) ; ES:DX = symbol table (scheme vector) (mov ib dh) #x22 (cld) (mov iw ax) (iw #x3200) (stos.w) (mov iw ax) (iw 256) (stos.w) (mov iw cx) (iw 512) ; number of words in vector (xor ax ax) ; store #f (stos.w cx) (push es) (push dx) ; global symbol table vector @ SS:#xFFE0 (int #x97) ; update alloc ptr (el sym.seg #xffda) (el sym.off #xffd8) (el top.stack #xffd8) ; ; setup pointer to end of call/cc stack copy ; (pointer points past last copied long) ; (el call/cc.point #xffd8) ;----------------------------------------------------------------------------- ; initialize system variables ;----------------------------------------------------------------------------- ; (() ; ; find size of DOS env ; (cs:) (mov (dw w) ds) (iw #x2c) ; DS:SI = DOS env (xor si si) (xor bp bp) ; BP = env length (cld) (l env.loop) ; scan env for two successive 0's (cmp iw bp) (iw 5000) (ja) (db env.too.long) (inc bp) (lods.b) (and al al) (jnz) (db env.loop) (inc bp) (lods.b) (and al al) (jnz) (db env.loop) (jmps) (db env.set.len) (l env.too.long) (call) (dw ps.con) (ss "DOS environment too long" 13 10) (l env.set.len) (ss:) (mov bp (dw w)) (aw env.length) ; save DOS env length ; ; scan DOS env at DS:0000 ending DS:SI for "S88PATH" ; (mov si cx) ; CX = ending si (xor si si) ; scan env for "S88PATH=" (cld) (l env.path.loop) (cmp cx si) (ja) (db env.no.path) (lods.b) (cmp ib al) #\S (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\8 (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\8 (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\P (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\A (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\T (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\H (jnz) (db env.path.loop) (lods.b) (cmp ib al) #\= (jnz) (db env.path.loop) (mov si cx) ; CX = 1st char of s88path (xor bp bp) ; BP = path length (cld) (l path.loop) ; scan path for 0 (cmp iw bp) (iw 100) (ja) (db path.too.long) (inc bp) (lods.b) (and al al) (jnz) (db path.loop) (dec bp) ; remove ending 0 (mov cx si) ; DS:SI = beginning BP = length (call) (dw heap.str2) ; copy to heap (push ax) (call) (dw ps.con) (ss "s88path set" 13 10) (pop ax) (jmps) (db path.set) (l path.too.long) (call) (dw ps.con) (ss "S88PATH too long" 13 10) (l env.no.path) (call) (dw heap.string) ; make empty path (ss "") ; ; set global "s88path" to DOS env variable ; (l path.set) (push ds) ; save s88path string on stack (push ax) (call) (dw heap.string) (ss "s88path") (int #x91) ; string -> symbol (xor ah ah) (mov ax si) ; DS:SI = untagged to symbol (pop di) ; ES:DI = string of s88path (pop es) (mov di (si db w)) 0 ; set! s88path string of s88path (mov es (si db w)) 2 ; ; put DOS evironment in symbol "dos-env" ; (cs:) (mov (dw w) ds) (iw #x2c) ; DS:SI = DOS env (xor si si) (ss:) (mov (dw w) bp) (aw env.length) ; BP = DOS env length (call) (dw heap.str2) ; copy to heap (push ds) ; save dos-env string on stack (push ax) (call) (dw heap.string) (ss "dos-env") (int #x91) ; string -> symbol (xor ah ah) (mov ax si) ; DS:SI = untagged to symbol (pop di) ; ES:DI = string of dos-env (pop es) (mov di (si db w)) 0 ; set! dos-env string of dos-env (mov es (si db w)) 2 ; ; put command line tail in symbol "args" ; (call) (dw heap.string) (ss "args") (int #x91) ; string -> symbol (xor ah ah) ; save untagged symbol (push ds) (push ax) (mov cs ax) ; DS:SI = command tail (mov ax ds) (mov iw si) (iw #x80) (mov (si b) al) (xor ah ah) (mov ax bp) (inc si) (call) (dw heap.str2) ; copy to heap (pop di) ; ES:DI = symbol "args" (pop es) (es:) (mov ax (di db w)) 0 ; set! args "command tail" (es:) (mov ds (di db w)) 2 ; ; put "%write" in symbol table (contents undefined) ; (call) (dw heap.string) (ss "%write") (int #x91) ; string -> symbol ; ; put primitive fast loader in symbol table as "%load" ; (call) (dw heap.string) (ss "%load") (int #x91) (mov iw bp) (aw100 load.closure) (mov iw si) (aw100 load.lco) (call) (dw set.symbol.closure) ; ; put call/cc in symbol table as "CALL/CC" ; (call) (dw heap.string) (ss "call/cc") (int #x91) (mov iw bp) (aw100 call/cc.closure) (mov iw si) (aw100 call/cc.lco) (call) (dw set.symbol.closure) ; ; put string-append in symbol table as "%string-append" ; (call) (dw heap.string) (ss "%string-append") (int #x91) (mov iw bp) (aw100 sapp.closure) (mov iw si) (aw100 sapp.lco) (call) (dw set.symbol.closure) ; ; put error in symbol table as "error" (contents undefined) ; (call) (dw heap.string) (ss "error") (int #x91) ; ; put garbage collector in symbol table as "%gc" (contents undefined) ; (call) (dw heap.string) (ss "%gc") (int #x91) ;------------------------------------------ ; load system functions ;------------------------------------------ ; (() (jmp) (dw load.sys) ; ; path appender subroutine (must far call this routine) ; DS:AX = file name ; value of global s88path = path ; (l path.append) (push ds) ; save file name (push ax) (call) (dw heap.string) (ss "s88path") (int #x91) ; DS:AX = symbol s88path (xor ah ah) (mov ax bx) (les (bx w) bx) ; ES:BX = value of symbol s88path (pop ax) ; DS:AX = file name (pop ds) (xor cx cx) ; dummy CP and FP (push cx) (push cx) (push cx) (push cx) (push es) ; path = arg1 (push bx) (push ds) ; file = arg2 (push ax) (call) (dw heap.string) (ss "%string-append") (int #x91) ; DS:AX = symbol string-append (xor ah ah) (mov ax bx) (lds (bx w) ax) ; DS:AX = value of symbol string-append (push ds) (push ax) (xor dx dx) ; no tail args (mov iw ax) (iw 2) ; 2 args (int #x93) ; ; path boot loader subroutine ; DS:AX = file name ; (l path.boot.load) (push cs) ; far call path append (call) (dw path.append) (call) (dw boot.loader) (ret) ; ; load system files ; (l load.sys) (call) (dw ps.con) (ss "Loading Scheme system files ") (call) (dw heap.string) (ss "pwrite.o") (call) (dw path.boot.load) (ss:) (mov (dw w) ax) (aw em.handle) ; are we using Expanded Memory? (and ax ax) (jnz) (db load.egc) (call) (dw heap.string) (ss "gc.o") (call) (dw path.boot.load) (jmps) (db load.errh) (l load.egc) (call) (dw heap.string) (ss "egc.o") (call) (dw path.boot.load) (l load.errh) (call) (dw heap.string) (ss "errh.o") (call) (dw path.boot.load) (call) (dw heap.string) (ss "lload.o") (call) (dw path.boot.load) (call) (dw heap.string) (ss "gsm.o") (call) (dw path.boot.load) (call) (dw heap.string) (ss "itor.o") (call) (dw path.boot.load) (call) (dw heap.string) (ss "dex.o") (call) (dw path.boot.load) ;------------------------------------------------------- ; loading scheme function with (%load "load-sys.so") ;------------------------------------------------------- (push cs) ; push top level return (mov iw ax) (aw100 top.return) (push ax) (mov cs bx) ; BX = segment for "%load" closure (mov iw ax) (aw100 load.closure) (mov ib cl) 4 (shr cl ax) (add ax bx) (push bx) ; push "%load" closure as current CP (xor ax ax) (push ax) (xor ax ax) ; push 0 BP as current FP (push ax) (mov iw ax) (iw #x0f00) (push ax) (call) (dw heap.string) ; append path to "load-sys.so" (ss "load-sys.so") (push cs) ; far call path append (call) (dw path.append) (push ds) ; push arg1 = path || "load-sys.so" (push ax) (mov sp bx) (ss:) (mov (bx db w) bx) 10 ; get "%load" closure segment from stack CP (push bx) ; push callee "%load" (mov iw ax) (iw #x2600) ; closure (push ax) (xor dx dx) ; 0 current args (mov iw ax) (iw 1) ; 1 callee arg (int #x93) ; print returned value (l top.return) (int #x95) (call) (dw fatal.error) ; return to DOS (ss " ") ;------------------------------------------------------------------------ ; set symbol in DS:AX to point to BCO in CS:BP and adjust BCO segment ;------------------------------------------------------------------------ (l set.symbol.bco) (mov ax bx) ; DS:BX untagged pointer to symbol (xor bh bh) (mov iw (bx w)) (iw #x2800) ; set symbol tags to BCO (mov bp ax) ; AX = offset of BCO / 16 (mov ib cl) 4 (shr cl ax) (mov cs dx) ; DX = CS (BCO segement) (add dx ax) ; AX = segment + BCO offset / 16 (mov ax (bx db w)) 2 ; set symbol segment (cs:) (mov ax (bp db w)) 6 ; set BCO segment (ret) ;------------------------------------------------------------------------ ; set symbol in DS:AX to point to CLOSURE in CS:BP ; and adjust CLOSURE code pointer segment to LCO CS:SI ;------------------------------------------------------------------------ (l set.symbol.closure) (mov ax bx) ; DS:BX untagged pointer to symbol (xor bh bh) (mov iw (bx w)) (iw #x2600) ; set symbol tags to LCO (mov bp ax) ; AX = offset of CLOSURE / 16 (mov ib cl) 4 (shr cl ax) (mov cs dx) ; DX = CS (CLOSURE segement) (add dx ax) ; AX = segment + CLOSURE offset / 16 (mov ax (bx db w)) 2 ; set symbol segment (mov si ax) ; AX = offset of LCO / 16 (mov ib cl) 4 (shr cl ax) (mov cs dx) ; DX = CS (LCO segement) (add dx ax) ; AX = segment + LCO offset / 16 (cs:) (mov ax (bp db w)) 6 ; set CLOSURE segment (ret) ;----------------------------------------------------------------------int# ; Debug interupt int #x03 ;-------------------------------------------------------------------------- ; (() (l new.int3) (push ax) (push bx) (push cx) (push dx) (push ds) (push si) (push es) (push di) (cs:) (fsave (dw d)) (aw100 int3.fstate) (fwait) (cs:) (frstor (dw d)) (aw100 int3.fstate) (fwait) (mov cs ax) ; initialize (mov ax es) (mov ax ds) (mov iw si) (aw100 int3.fstate) (mov iw di) (aw100 int3.sbuf) (xor dx dx) (cld) ; ; print control info ; (call) (dw str.sbuf) (ss 13 10 "FCW=") (mov (si db w) ax) 0 (call) (dw hex.ax) (call) (dw str.sbuf) (ss " FSW=") (mov (si db w) ax) 2 (call) (dw hex.ax) (call) (dw str.sbuf) (ss " FTW=") (mov (si db w) ax) 4 (call) (dw hex.ax) (mov ib al) 13 (stos.b) (inc dx) (mov ib al) 10 (stos.b) (inc dx) (call) (dw prt.sbuf) ; ; print x87 stack ; (mov iw si) (aw100 int3.fstate) (add ib si) 92 (mov iw cx) (iw 8) (l int3.sloop) (mov iw di) (aw100 int3.sbuf) (xor dx dx) (cld) (mov ib al) #\S (stos.b) (inc dx) ; register # (mov cx ax) (dec ax) (call) (dw hex.digit) (mov ib al) #\space (stos.b) (inc dx) (mov (si w) ax) ; exp (sub ib si) 2 (call) (dw hex.ax) (mov ib al) #\: (stos.b) (inc dx) (mov (si w) ax) ; man (sub ib si) 2 (call) (dw hex.ax) (mov (si w) ax) ; man (sub ib si) 2 (call) (dw hex.ax) (mov (si w) ax) ; man (sub ib si) 2 (call) (dw hex.ax) (mov (si w) ax) ; man (sub ib si) 2 (call) (dw hex.ax) (mov ib al) 13 (stos.b) (inc dx) ; CR LF (mov ib al) 10 (stos.b) (inc dx) (call) (dw prt.sbuf) (loop) (db int3.sloop) (pop di) (pop es) (pop si) (pop ds) (pop dx) (pop cx) (pop bx) (pop ax) (push bp) ; code displaced by modifying DEBUG (mov sp bp) (dec (bp db w)) 2 (pop bp) (jmpf) (l old.int3) (iw 0) (iw 0) ; ; put ascii hex digits of AX at ES:DI ; (l hex.AX) (push ax) (push cx) (mov ib cl) 12 (shr cl ax) (pop cx) (call) (dw hex.digit) (pop ax) (push ax) (push cx) (mov ib cl) 8 (shr cl ax) (pop cx) (call) (dw hex.digit) (pop ax) ; ; put ascii hex digits of AL at ES:DI ; (l hex.AL) (push ax) (push cx) (mov ib cl) 4 (shr cl ax) (pop cx) (call) (dw hex.digit) (pop ax) ; ; put ascii hex digit of AL & 0f at ES:DI inc dx ; (l hex.digit) (and iw ax) (iw #xf) (cmp ib al) 10 (jb) (db hex.num) (add ib al) 7 (l hex.num) (add ib al) #\0 (stos.b) (inc dx) (ret) ; ; put string following call in sbuf ; (l str.sbuf) (pop ax) (push ds) (push si) (push cx) (mov ax si) ; SI = return address (mov cs ax) (mov ax ds) ; DS:SI = string (mov (si db w) cx) 2 ; cx = string length (add cx dx) (add ib si) 4 (cld) (movs.b cx) ; copy string (inc si) ; skip ending 0 (mov si ax) (pop cx) (pop si) (pop ds) (push ax) (ret) ; ; print int3.sbuf ; (l prt.sbuf) (push cx) (mov dx cx) ; put word length in cx (mov iw dx) (aw100 int3.sbuf) ; dx=offset to string (mov cs ax) ; ds=segment to string (mov ax ds) (mov iw bx) (iw 1) (mov iw ax) (iw #x4000) (int #x21) (pop cx) (ret) ; ; x87 state holding table ; .align-para (l int3.fstate) 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (l int3.sbuf) (ss " ") ;----------------------------------------------------------------------int# ; Control Break interupt int #x1B ;-------------------------------------------------------------------------- ; (() (l ctrl.break) (cs:) (inc (dw w)) (aw break.flag) ; SS is set to DOS stack (iret) ; so use CS: ;----------------------------------------------------------------------int# ; Control C & Control Break interupt int #x23 ;-------------------------------------------------------------------------- ; (() (l ctrl.cb) (cs:) (inc (dw w)) (aw break.flag) ; SS is set to DOS stack (iret) ; so use CS: ;----------------------------------------------------------------------int# ; int #x92 stack check ; *** if ax is used then apply must be fixed ;-------------------------------------------------------------------------- ; (() ; (l stack.check) ; (add iw ax) (l stack.bottom) (aw100 boot.end.init) ;aw is modified+0x100 ; (jb) (db stack.err) ; (cmp sp ax) ; (ja) (db stack.err) ; (iret) (l stack.check) (cmp iw sp) (l stack.bottom) (aw100 boot.end.init) ;aw is modified+0x100 (jb) (db stack.err) (iret) (l stack.err) (pop ax) (pop ax) (popf) (mov iw sp) (aw top.stack) ; move stack pointer to top (call) (dw ps.con) (ss 13 10 "ERROR: stack overflow" 13 10) (int #x9e) ; call scheme error ;----------------------------------------------------------------------int# ; Space Check and Garbage Collection caller int #x96 ; enter: AX = number of paragraph (16 bytes) needed ; BP = FP if caller return address collectible (BCO or LCO) ; = 0 if not ; return: ES:DI = allocation pointer (old contents not saved) ; BP = 0 (old contents not saved) ; CX is bashed ;-------------------------------------------------------------------------- ; (() (l requested.size) (iw 0) (l requested.end) (iw 0) (l space.check) (cs:) (mov ax (dw w)) (aw100 requested.size) (ss:) (les (dw w) di) (aw heap.off) ; ES:DI=scheme alloc pointer (mov es cx) ; check for end of semi space ; (ss:) (cmp (dw w) cx) (aw cur.end.seg) ; compare alloc to semi-space end ; (ja) (db space.check.error) (add ax cx) (jo) (db space.check.gc) (cs:) (mov cx (dw w)) (aw100 requested.end) ; save requested end (add ib cx) 5 ; add 5 paras for margin (ss:) (cmp (dw w) cx) (aw cur.end.seg) ; compare alloc+need to end (jae) (db space.check.gc) (iret) ; (l space.check.error) ; (call) (dw fatal.error) ; (ss 13 10 "FATAL ERROR: allocation pointer outside semi-space") (l space.check.gc) (pop dx) (pop bx) (popf) (ss:) (mov (dw w) cx) (aw critical.f) ; check for no gc (and cx cx) (jz) (db space.check.collect) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: GC in critical area") (l space.check.collect) ; ; stack frame for int #x96 ; (push bx) ; push return address (push dx) (xor bx bx) (push bx) ; push non-collectible CP (push bx) (push bp) ; return FP of int #f1 caller (mov iw bx) (iw #x0f00) (push bx) ; ; stack frame for GC ; (push ax) ; push number of paragraphs needed (mov iw ax) (iw #x0800) (push ax) (push cs) ; push return (mov iw ax) (aw100 gc.ret.p) (push ax) (xor ax ax) (push ax) ; CP = 0 (push ax) (push ax) ; FP = 0 (mov iw ax) (iw #x0f00) (push ax) (cs:) (jmpf (dw w)) (aw garbage.collect) ; ; return from GC let ES:DI = alloc pointer ; (l gc.ret.p) (pop bp) (pop bp) (pop es) (pop di) (ss:) (les (dw w) di) (aw heap.off) ; ES:DI=scheme alloc pointer (cs:) (mov es ax) ; recompute requested end (cs:) (add (dw w) ax) (aw100 requested.size) (cs:) (mov ax (dw w)) (aw100 requested.end) (retf) ;----------------------------------------------------------------------int# ; Allocation Pointer Update int #x97 ; enter: ES:DI = un-adjusted allocation pointer ; return: updated allocation pointer (saved at top of stack) ; AX is saved ;-------------------------------------------------------------------------- ; (() (l alloc.update) (push ax) (mov di ax) ; and object end offset with 000F (and iw ax) (iw #x000f) (ss:) (mov ax (dw w)) (aw heap.off); write free space offset 0-f (and ib al) 3 (jnz) (db alloc.mis.err) (shr di) ; divide object end offset by 16 (shr di) (shr di) (shr di) (mov es ax) (add di ax) ; add to free space segment (ss:) (mov ax (dw w)) (aw heap.seg); write free space segment (cs:) (cmp (dw w) ax) (aw100 requested.end) ; cmp requested end (ja) (db alloc.up.err) (l alloc.up.ret) (pop ax) (iret) (l alloc.mis.err) (pop bx) (pop bx) (popf) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: alloc update: alloc pointer misaligned") (l alloc.up.err) (sti) (push bx) (cs:) (sub (dw w) ax) (aw100 requested.end) ; subtract requested end (push ax) (cs:) (mov (dw w) ax) (aw100 requested.size) (push ax) (call) (dw format) (ss "ALLOCATION ERROR: requested %d but used %d more in ") (mov sp bx) (push ds) (ss:) (mov (bx db w) ax) 8 ; get return segment (ss:) (callf (dw w)) (aw gsm.function) (int #x95) (pop ds) (int3) (call) (dw ps.con) (ss 13 10) (pop bx) (jmp) (dw alloc.up.ret) ;----------------------------------------------------------------------int# ; Closure Allocator int #x98 ; enter: AX = closure size ; stack = object to be put in closure ; return: DS:AX = new closure ; note: does not return to caller; returns to previous caller ;-------------------------------------------------------------------------- ; (() (l closure.alloc) (pop bx) ; discard return (pop bx) (popf) (pop bx) ; pop untagged LCO body pointer (pop dx) (push dx) ; push LCO body segment as tagged LCO (mov iw cx) (iw #x2c00) (push cx) (push bx) ; push LCO body offset as fixnum (mov iw cx) (iw #x0800) (push cx) (push ax) ; push size (mov iw cx) (iw #x0800) (push cx) (add iw ax) (iw 4) ; add 1 for header & 3 to round up (shr ax) (shr ax) ; AX = number of paras needed (xor bp bp) ; return not collectible (int #x96) ; space check and GC ES:DI = alloc ptr (pop cx) ; pop CX = size in longs (pop cx) (pop bx) ; pop BX = LCO body offset (pop bx) (pop dx) ; pop DX = LCO body segment (pop dx) (push dx) ; push untagged LCO body pointer (push bx) (mov cx bx) ; BX = size in longs (mov di dx) (mov ib dh) #x26 ; DX = type & offset (cld) (mov iw ax) (iw #x3600) ; put header in closure (stos.w) (mov cx ax) (stos.w) (add cx cx) ; CX = size in words (mov ss ax) ; DS:SI = untagged to stack (mov ax ds) (mov sp si) (movs.w cx) ; copy from stack to closure (add bx bx) ; BX = size in bytes (add bx bx) (add bx sp) ; adjust stack pointer (mov es ax) ; DS = segment of new closure (mov ax ds) (int #x97) ; adjust alloc ptr (mov dx ax) ; DS:AX = new closure (pop bp) (pop bp) (pop di) (pop es) (retf) ;----------------------------------------------------------------------int# ; Box Allocator int #x99 ; enter: DS:AX = object ; return: DS:AX = (box object) ;-------------------------------------------------------------------------- ; (() (l box.alloc) (pop dx) ; return (pop bx) (popf) (push bx) ; push return (push dx) (push es) ; push CP (push di) (push bp) ; push FP (mov iw bx) (iw #x0f00) (push bx) (push ds) ; push object (push ax) (mov iw ax) (iw 1) ; need 1 para (xor bp bp) ; return not collectible (int #x96) ; space check and GC ES:DI = alloc ptr (mov es ax) ; DS:DX = new box (mov ax ds) (mov di dx) (mov ib dh) #x10 ; DX = type & offset (cld) (pop ax) ; put object in box (stos.w) (pop ax) (stos.w) (int #x97) ; adjust alloc ptr (mov dx ax) ; DS:AX = new closure (pop bp) (pop bp) (pop di) (pop es) (retf) ;------------------------------------------------------------------------int# ; INT FUNCTION NOT USED ; Bignum Allocator int #x9a Must be called from BCO bashes ES:DI & BP ; enter: AX = word size of bignum ; stack = bignum words ; return: DS:AX = bignum ;---------------------------------------------------------------------------- ; (() (l bignum.alloc) (sti) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: bignum allocator") ;----------------------------------------------------------------------int# ; List Allocator int #x9b ; enter: AX = number of args ; stack = args ; return: DS:AX = list ;-------------------------------------------------------------------------- ; (() (l list.alloc.null) ; if zero args then return null (xor ax ax) (mov ax ds) (inc ah) (iret) ;-------------------------------- ; list allocator ;-------------------------------- (l list.alloc) (and ax ax) (jz) (db list.alloc.null) (pop dx) ; return (pop bx) (popf) (push bx) ; push return (push dx) (push es) ; push CP (push di) (push bp) ; push FP (mov iw bx) (iw #x0f00) (push bx) ; (push ax) ; save number args (mov iw bx) (iw #x0800) (push bx) (add iw ax) (iw 2); AX = number paras needed for pairs (shr ax) (xor bp bp) ; return not collectible (int #x96) ; space check & GC ES:DI = alloc pointer (pop cx) ; CX = number args (pop cx) (mov cx ax) ; save # args * 4 at retaf instruction (add ax ax) ; to pop args after return (add ax ax) (cs:) (mov ax (dw w)) (aw100 list.alloc.kill) (mov sp bp) ; SS:BP = untagged to first arg (add ib bp) 12 (xor ax ax) ; DS:SI = () (mov ax ds) (mov iw si) (iw #x0100) ; ; loop test ; (l list.loop) (and cx cx) (jz) (db list.end) ; ; allocate pair ; (mov es dx) ; DX:BX = new pair (mov di bx) (mov ib bh) #x11 (cld) (ss:) (mov (bp db w) ax) 0 ; CAR = stack arg (stos.w) (ss:) (mov (bp db w) ax) 2 (stos.w) (add ib bp) 4 ; SS:BP = untagged to next arg (dec cx) ; count down 1 arg (mov si ax) ; CDR = DS:SI (stos.w) (mov ds ax) (stos.w) ; ; update alloc pointer ; (cmp iw di) (iw #x0010) (jb) (db list.up.ok) (and iw di) (iw #x000f) (mov es ax) (inc ax) (mov ax es) (l list.up.ok) ; ; DS:SI = DX:BX (new pair) ; (mov dx ds) (mov bx si) (jmp) (dw list.loop) ; (l list.end) ; DS:AX = list (mov si ax) (int #x97) ; update alloc ptr (pop bp) (pop bp) (pop di) (pop es) (retaf) (l list.alloc.kill) (iw 0) ;----------------------------------------------------------------------int# ; cons Allocator int #x9c ; enter: DS:AX = cdr ; stack = car ; return: DS:AX = (cons car cdr) ;-------------------------------------------------------------------------- ; (() (l cons.alloc) (pop dx) ; POP return (pop bx) (popf) (pop cx) ; POP SI:CX = car (pop si) (push ds) ; push cdr (push ax) (push si) ; push car (push cx) (push bx) ; push return (push dx) (push es) ; push CP (push di) (push bp) ; push FP (mov iw bx) (iw #x0f00) (push bx) ; (mov iw ax) (iw 1); AX = number paras needed for cons cell (xor bp bp) ; return not collectible (int #x96) ; space check & GC ES:DI = alloc pointer (mov sp si) ; DS:SI = untagged to arg1 (add ib si) 12 (mov ss ax) (mov ax ds) (mov iw cx) (iw 4) ; CX = number words to copy ; ; allocate cons cell ; (mov es dx) ; DX:AX = new pair (mov di ax) (mov ib ah) #x11 (cld) (movs.w cx) ; copy args from stack (mov dx ds) ; DS:AX = (new cons cell) (int #x97) ; update alloc ptr (pop bp) (pop bp) (pop di) (pop es) (retaf) (iw 8) ;----------------------------------------------------------------------int# ; integer->real int #x9d ; enter: DS:AX = integer ; return: DS:AX = real ;-------------------------------------------------------------------------- (l int->real) (pop dx) ; POP return (pop bx) (popf) (push ds) ; push integer (push ax) (push bx) ; push return (push dx) (ss:) (jmpf (dw w)) (aw itor.function) ;-------------------------------------------------------------------------int# ; call scheme "error" int #x9e ; call the scheme procedure "error" if it exists ;----------------------------------------------------------------------------- (l call.error) (pop ax) ; discard return address (pop ax) (popf) ; ; get contents of error from symbol table ; (mov cs ax) ; AX = string "error" segment (call) (iw 0) (l err.str.base); BX = current PC (pop bx) (add iw bx) (aw err.str.off); BX = BX + offset to string "error" (mov ib cl) 4 (shr cl bx) (add bx ax) (mov ax ds) (mov iw ax) (iw #x2000) (mov iw bx) (iw 1) ; set critical area flag (no allocation) (ss:) (mov bx (dw w)) (aw critical.f) (int #x91) ; (string->symbol "error") (xor bx bx) ; reset critical area flag (ss:) (mov bx (dw w)) (aw critical.f) (xor ah ah) (mov ax bx) (lds (bx w) ax) ; DS:AX = contents of error (cmp ib ah) #x26 ; is it a closure? (jz) (db call.err.call) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: error function not defined") ; ; call error ; (l call.err.call) (push ds) (push ax) (xor ax ax) (xor dx dx) (int #x93) .align-para (dl err.str.off err.str.base) (ss "error") ;************************************************************************** ;-------------------------------------------------------------------------- ; scheme primitive loader %load loads files or Code Vector Objects ;-------------------------------------------------------------------------- .align-para (l load.closure) (iw #x3600) (iw #x0001) (aw load.start) (iw 0) ; segment goes here .align-para (l load.lco) ; lambda code object header (iw #x3C00) (aw load.size) (iw 0) ; new closures are not created (iw 0) (iw #x0800) (iw #x0000) (dl load.start load.lco) (ss:) (jmpf (dw w)) (aw low.load) (dl load.size load.lco) ;-------------------------------------------------------------------------- ; string append for 2 args (used for loading system files from path) ;-------------------------------------------------------------------------- .align-para (l sapp.closure) (iw #x3600) (iw #x0001) (aw sapp.start) (iw 0) ; segment goes here .align-para (l sapp.lco) ; lambda code object header (iw #x3C00) (aw sapp.size) (iw 0) ; new closures are not created (iw 0) (iw #x0800) (iw #x0000) (dl sapp.start sapp.lco) ; (mov sp bp) ; bound var base (cmp iw ax) (iw 2) ; check number args = 2 (jz) (db sapp.args.ck) (mov ib dl) 1 (int #x90) ; (l sapp.args.ck) (ss:) (lds (bp db w) bx) 4 ; DS:BX = arg1 (cmp ib bh) #x20 ; string? (jz) (db sapp.arg2.ck) (mov ib dl) 122 (int #x90) (l sapp.arg2.ck) (xor bh bh) (mov (bx db w) cx) 2 ; CX = length string 1 (ss:) (lds (bp db w) bx) 0 ; DS:BX = arg2 (cmp ib bh) #x20 ; string? (jz) (db sapp.arg.ok2) (mov ib dl) 122 (int #x90) (l sapp.arg.ok2) (xor bh bh) (add (bx db w) cx) 2 ; CX = length string 1 + length string 2 (jnb) (db sapp.size.ck) (mov ib dl) 10 (int #x90) (l sapp.size.ck) (cmp iw cx) (iw 64000) ; <= 64000 (jna) (db sapp.arg.ok) (mov ib dl) 10 (int #x90) ; ; save size ; (l sapp.arg.ok) (push cx) ; save byte size of string (mov iw ax) (iw #x0800) (push ax) ; ; check space in heap ; (mov cx ax) ; AX = byte size of string (add iw ax) (iw 20) ; add 1 for zero end, 4 for header, 15 to round up (mov ib cl) 4 ; divide by 16 (shr cl ax) ; AX = number paras needed (int #x96) ; space check and gc call ES:DI = allocation ptr ; ; allocate string ; (mov di dx) ; DX = pair type & offset (mov ib dh) #x20 (cld) (mov iw ax) (iw #x3000) ; string header (stos.w) (pop ax) ; AX = byte size of string (pop ax) (stos.w) (ss:) (lds (bp db w) bx) 4 ; DS:BX = arg1 (xor bh bh) (mov (bx db w) cx) 2 ; CX = length string 1 (mov bx si) (add ib si) 4 (movs.b cx) ; copy (ss:) (lds (bp db w) bx) 0 ; DS:BX = arg2 (xor bh bh) (mov (bx db w) cx) 2 ; CX = length string 2 (mov bx si) (add ib si) 4 (movs.b cx) ; copy (xor al al) ; store ending zero (stos.b) (add ib di) 3 ; round up ES:DI to long (and iw di) (iw #xfffc) (mov es ax) ; DS:AX = new string (mov ax ds) (mov dx ax) ; ; update free space pointer ; (int #x97) ; allocation ptr = adjusted ES:DI (add ib sp) 8 ; kill args (pop bp) (pop bp) (pop di) (pop es) (retf) (dl sapp.size sapp.lco) ;---------------------------------------------------------------------------- ; call/cc CLOSURE ;---------------------------------------------------------------------------- .align-para (l call/cc.closure) (iw #x3600) (iw #x0001) (aw call/cc.start) (iw 0) ; segment goes here .align-para (l call/cc.lco) ; body code object header (iw #x3C00) (aw call/cc.size) (iw 0) ; new closures are not created (iw 0) (iw #x0800) (iw #x0000) (dl call/cc.start call/cc.lco) (cmp iw ax) (iw 1) ; do we have 1 arg? (jz) (db ccc.1arg) (mov ib dl) 1 (int #x90) (l ccc.1arg) (mov sp bp) ; set FP (mov iw ax) (aw call/cc.point) ; AX = size of continuation in bytes (sub sp ax) (sub iw ax) (iw 4) ; take arg1 off size (mov ax bx) ; BX = AX (and iw ax) (iw 3) ; is stack aligned? (jz) (db ccc.stack.ok) (call) (dw error) (ss 13 10 "ERROR stack misaligned during call/cc" 13 10) (l ccc.stack.ok) (shr bx) (push bx) ; push word size of cont. as fixnum (mov iw ax) (iw #x0800) (push ax) (shr bx) ; BX = long word size of cont. (add ib bx) 3 ; BX = round up to next para (shr bx) (shr bx) (inc bx) ; add 1 for para align (mov bx ax) ; AX = number of paras needed (int #x96) ; space check & GC ES:DI = alloc ptr (mov es ax) ; DS:DX = tagged continuation (mov ax ds) (mov di dx) (mov ib dh) #x2a (pop cx) ; CX = word size of cont. (pop cx) (mov cx bx) ; BX = word size of cont. (shr bx) ; BX = long size of cont. (cld) (mov iw ax) (iw #x3a00) ; create header 3A00 size (stos.w) (mov bx ax) (stos.w) (add cx di) ; add byte size of cont to alloc ptr (add cx di) (int #x97) ; update alloc ptr (push ds) ; save continuation DS:DX on stack (push dx) (mov ds bx) ; ES:DI untagged to first long in cont. (dest.) (mov bx es) (xor dh dh) (add ib dx) 4 ; skip cont. header (mov dx di) (mov ss bx) ; DS:SI points to stack (source of continuation) (mov bx ds) (mov sp si) (add ib si) 8 ; adjust for saved continuation & arg1 (cld) ; CX = word size of cont. (movs.w cx) ; copy stack to cont. (pop ax) ; DS:AX = continuation (pop ds) (pop di) ; ES:DI = pop call/cc arg1 (receiver function) (pop es) (mov sp bp) ; set FP (push ds) ; push continuation as arg1 for callee (push ax) (push es) ; push call/cc arg1 (receiver function) (push di) (mov iw ax) (iw 1) ; number callee args = 1 (xor dx dx) ; number current args = 0 (int #x93) ; call receiver (dl call/cc.size call/cc.lco) ;------------------------------------------------------------------------int# ; int #x94 Scheme function apply ; AX = number args for call ; DX = number args for current frame 0 = rec call or tail with 0 current ; top stack = function (popped before call) ; next to top stack = list to convert to args ; BP = frame pointer ; stack = args ;---------------------------------------------------------------------------- ; (() (l fun.app.off) (iw 0) ; save function here (l fun.app.seg) (iw 0) (l fun.apply) (pop bx) ; return offset (cs:) (mov bx (dw w)) (aw100 fun.caller.off) (pop bx) ; return segment (cs:) (mov bx (dw w)) (aw100 fun.caller.seg) (popf) ; take pushed flags off stack (and ax ax) (jnz) (db fun.apply.arg.ok) (call) (dw error) (ss "ERROR: tried to apply function with zero args" 13 10) (l fun.apply.arg.ok) (mov ax cx) ; CX = arg count (pop ax) ; save function for after list->stack (cs:) (mov ax (dw w)) (aw100 fun.app.off) (pop ax) (cs:) (mov ax (dw w)) (aw100 fun.app.seg) (pop ax) ; DS:AX = last arg (pop ds) (dec cx) ; arg count = arg count - 1 (l fun.app.loop) ;;; DS:AX = tagged pair or null (int #x92) ; stack check (cmp IB AH) (IB #x01) ;;; Check if null (je) (DB fun.app.end) (cmp ib ah) (ib #x11) (je) (db fun.app.pair) (call) (dw error) (ss "ERROR: tried to apply function with bad list" 13 10) (l fun.app.pair) (inc CX) (xor AH AH) ;;; Clear Tag (mov AX SI) ;;; DS:SI = untagged ptr to pair (les (SI W) DI) ;;; Get Car (push ES) ;;; Push Car on Stack (push DI) (lds (si db w) ax) 4 ;;; Get cdr (jmps) (DB fun.app.loop) ;;; Go to Loop (l fun.app.end) ;;; We have the args on the stack (cs:) (mov (dw w) ax) (aw100 fun.app.seg) ; replace function on stack (push ax) (cs:) (mov (dw w) ax) (aw100 fun.app.off) (push ax) (mov cx ax) ; AX = # args DX = current args (jmp) (dw fun.call.enter) ;------------------------------------------------------------------------int# ; int #x93 Scheme function caller ; AX = number args for call ; DX = number args for current frame 0 = rec call or tail with 0 current ; top stack = function (popped before call) ; BP = frame pointer ; stack = args ;---------------------------------------------------------------------------- ; (() (l fun.caller.off) (iw 0) ; save caller's address here for error handler (l fun.caller.seg) (iw 0) (l fun.call) (pop bx) ; return offset (cs:) (mov bx (dw w)) (aw100 fun.caller.off) (pop bx) ; return segment (cs:) (mov bx (dw w)) (aw100 fun.caller.seg) (popf) ; take pushed flags off stack (int #x92) ;************************************************ stack check (l fun.call.enter) (and dx dx) (jz) (db fun.break) ; ; copy back stack on tail call ; (mov ss si) ;copy back stack (mov si ds) (mov si es) (mov bp si) ;top word of caller frame DS:SI source (sub ib si) (ib 2) (mov bp di) ;top word of callee frame ES:DI dest (add dx dx) ; dx = (* 4 num-args current) (add dx dx) (add dx di) ; di = (+ BP DX -2) (sub ib di) (ib 2) (mov ax cx) ; cx = (+ 2 (* 2 num-args call)) +2 for function (add ax cx) (add ib cx) (ib 2) (std) (movs.w cx) ;copy stack (add dx sp) ;adjust stack pointer ; ; check for control break ; (l fun.break) (ss:) (mov (dw w) bx) (aw break.flag) (and bx bx) (jz) (db fun.rec.call) (xor ax ax) (ss:) (mov ax (dw w)) (aw break.flag) (xor dl dl) (jmp) (dw fun.error) ; ; call to closure object ; (l fun.rec.call) (pop bx) ; ES:BX = function (pop es) (cmp IB BH) (IB #x26) (jnz) (db fun.bco.ck) ; AX = number calling args (xor bh bh) ; ES:DI = untagged closure pointer (mov bx di) (es:) (jmpf (di db w)) (ib 4) ; ; call to BCO ; (l fun.bco.ck) (cmp IB BH) (IB #x28) (jnz) (db fun.cont.ck) (xor bh bh) (mov bx di) (xor bp bp) ; set BP (frame pointer) to 0 (es:) (callf (bx db w)) (ib 4) (pop bp) (pop bp) (pop di) (pop es) (retf) ; ; check for continuation ; (l fun.cont.ck) (cmp ib bh) (ib #x2a) (jz) (db fun.cont.invoke) (mov ib dl) 2 (jmp) (dw fun.error) ; ; invoke continuation ; (l fun.cont.invoke) (dec ax) (jz) (db ll.cont.arg.ok) (call) (dw error) (ss "ERROR: continuation invoke with wrong # args" 13 10) (l ll.cont.arg.ok) (mov es ax) ; DS:SI = untagged continuation contents (mov ax ds) (xor bh bh) (mov bx si) (mov (db si w) cx) 2 ; CX = cont long length (add cx cx) ; CX = cont word length (mov cx ax) ; AX = cont byte length (add ax ax) (mov iw bx) (aw call/cc.point) (sub ax bx) ; BX = new stack pointer (pop ax) ; DX:AX = pop cont. arg1 (pop dx) (mov bx sp) ; SP = BX set stack pointer (mov bx di) ; ES:DI = stack above cont. arg1 (dest. for copy) (mov ss bx) (mov bx es) (add ib si) 4 ; DS:SI points to first cont. long (source for copy) (cld) (movs.w cx) ; copy continuation into stack (mov dx ds) ; DS:AX = continuation arg1 (pop bp) ; restore FP & CP and return (pop bp) (pop di) (pop es) (retf) ; ; calling error ES:BX = non-closure-value ; (l fun.error) (cs:) (mov (dw w) si) (aw100 fun.caller.seg) ; SI:CX = caller address (cs:) (mov (dw w) cx) (aw100 fun.caller.off) (ss:) (jmpf (dw w)) (aw error.handler) ;************************************ old code ; (call) (dw ps.con) ; (ss 13 10 "ERROR: non-closure-invoked: ") ; ; (mov es ax) ; (mov ax ds) ; (mov bx ax) ; (int #x95) ; print non-closure value ; ; (cs:) (lds (dw w) si) (aw100 fun.caller.off) ;get caller address ; (sub ib si) 19 ; back up pointer to possible global lookup ; (mov (si b) al) ; check for CS: ; (cmp ib al) #x2e ; (jnz) (db fun.err.end) ; (inc si) ; check for LDS (DW W) BX ; (mov (si w) ax) ; (cmp iw ax) (iw #x1ec5) ; (jnz) (db fun.err.end) ; ; (call) (dw ps.con) ; (ss 13 10 "GLOBAL REF: ") ; ; (mov (si db w) si) 2 ; DS:SI = pointer to global in LCO ; (lds (si w) ax) ; DS:AX = global ; (int #x95) ; print global value ; ; (l fun.err.end) ; (call) (dw error) ; do not cont. ; (ss 13 10) ;------------------------------------------------------------------------int# ; int #x9f low level error for BCO's that do not push CP & FP ; DL = error number ;---------------------------------------------------------------------------- ; (() (l ll.error.bco) (pop cx) ; return offset (pop si) ; return segment (popf) ; take pushed flags off stack (push es) (push di) (push bp) (mov iw bp) (iw #x0f00) (push bp) (ss:) (jmpf (dw w)) (aw error.handler) ;------------------------------------------------------------------------int# ; int #x90 low level error ; DL = error number ;---------------------------------------------------------------------------- ; (() (l ll.error) (pop cx) ; return offset (pop si) ; return segment (popf) ; take pushed flags off stack (ss:) (jmpf (dw w)) (aw error.handler) ;-------------------------------------------------------------------------int# ; int #xa0 exit Scheme to DOS ; restore interupts and wipe memory ;----------------------------------------------------------------------------- (l exit.to.dos) ; exit Scheme (pop ax) (pop ax) (popf) ; ; deallocate Expanded Memory Pages (if used) ; (ss:) (mov (dw w) ax) (aw em.handle) (and ax ax) (jz) (db exit.wipe) (mov ax dx) ; deallocate all memory by handle DX (mov iw ax) (iw #x4500) (int #x67) (and ah ah) (jz) (db exit.wipe) (call) (dw ps.con) (ss 13 10 "Expanded Memory Manger ERROR: deallocation problem" 13 10) ; ; wipe memory ; (l exit.wipe) (ss:) (mov (dw w) cx) (aw heap.end.seg) (ss:) (mov (dw w) ax) (aw heap.begin.seg) (mov ax es) ; ES:0000 = start of heap memory (sub ax cx) ; CX = number of heap paragraphs (l wipe.loop) (xor di di) (xor ax ax) (cld) (stos.w) (stos.w) (stos.w) (stos.w) (stos.w) (stos.w) (stos.w) (stos.w) (mov es ax) (inc ax) (mov ax es) (loop) (db wipe.loop) ; ; restore interupts ; (mov cs ax) ; ES:DI = int table (mov ax es) (mov iw di) (aw100 boot.int.table) (mov iw cx) (aw number.ints) ; CX = number of ints (l int.restore.loop) (cld) (es:) (mov (di w) ax) ; AX = int number (es:) (mov (di db w) dx) 2 ; save current vector (es:) (mov (di db w) ds) 4 (add ib di) 8 (mov ib ah) #x25 (int #x21) (loop) (db int.restore.loop) (mov iw ax) (iw #x4c00) ; never returns (go back to DOS) (int #x21) ;-------------------------------------------------------------------------int# ; int #xa1 DOS EXEC function ; ES:DI = untagged scheme string containing program name ; DS:SI = untagged scheme string containing command tail ; DX:CX = untagged scheme string containing the new environment ; or current env. if string = "" ; This function assumes memory is collected and in the 1st semi-space. ; It deallocates memory from avail to end, EXEC's the program, and returns ; to scheme. ;----------------------------------------------------------------------------- ; (() (l dos.exec) (pop bx) ; pop and push return (pop ax) (popf) (push ax) (push bx) (ss:) (jmpf (dw w)) (aw dex) ;------------------------------------------------------------------------int# ; int #x91 string->symbol global symbol table ; call: DS:AX points to input scheme string ; return: DS:AX points to symbol ; bashes bx,cx,dx,si ; ; The symbol table is a vector of 256 elements. ; Each vector element is #f or a proper list. ; If a vector element is a list, then the car of each pair is a symbol ; ; NOTE: input string is not copied, so it must not be side affected ;----------------------------------------------------------------------------- ; ; convert string DS:AX to lower case ; (l string.down) (push ax) (xor ah ah) ; ES:DI = untagged pointer to string (mov ax di) (mov ds ax) (mov ax es) (cld) (es:) (mov (di db w) cx) 2 ; cx = string length (add iw di) (iw 4) (l char.down) (es:) (mov (di b) al) ; get char from string (cmp ib al) #\A (jb) (db char.ok) (cmp ib al) #\Z (ja) (db char.ok) (or ib al) #x20 (l char.ok) (stos.b) (loop) (db char.down) (pop ax) (ret) ;----------------------------------------------------------- ; string->symbol ;----------------------------------------------------------- ; (() (l str->sym) (pop bx) ; take pushed flags off stack (pop cx) (popf) (push cx) ; put return back on (push bx) (push es) ; save CP (push di) (push bp) ; save FP (mov iw bp) (iw #x0f00) (push bp) ; ; check heap for symbol and pair space ; (ss:) (mov (dw w) bx) (aw critical.f) ; check no allocation flag (and bx bx) (jnz) (db ss.no.alloc) (push ds) ; push input (push ax) (xor bp bp) ; return address not collectible (mov iw ax) (iw 2) (int #x96) ; space check & GC (pop ax) (pop ds) (l ss.no.alloc) ; ; check input for string ; (cmp ib ah) #x20 ; is input string? (jz) (db sym.is) (cmp ib ah) #x03 (jz) (db sym.table) (call) (dw error) (ss "ERROR: string->symbol of non-string" 13 10) ; ; return symbol table vector (stv) ; (l sym.table) ; return symbol table vector if arg #unspecified (ss:) (lds (dw w) ax) (aw sym.off); put tagged pointer in DS:AX (jmp) (dw sym.end) ; ; string->symbol of string in DS:AX ; (l sym.is) ; (call) (dw string.down) ;***** down cases for total case insensitivity (mov ax si) ; put taged pointer to input string in DS:SI (call) (dw sym.hash) ; ax=hash(input) (call) (dw sym.index) ; ES:DI is untaged pointer to stv(ax) (l sym.list.loop) (es:) (mov (di w) ax) ; get tags of stv(ax) (cmp ib ah) #x11 ; is it a pair? (jnz) (db sym.make.new) (es:) (les (di w) ax) ; ES:AX=taged pointer @ ES:DI (xor ah ah) (mov ax di) ; ES:DI=untaged pointer (push di) ; save pointer ES:DI (push es) (es:) (les (di w) di) ; ES:DI=taged car of pair ES:DI (call) (dw str=sym?) ; compare input & symbol print name (jz) (db sym.found) (pop es) (pop di) (add iw di) (iw 4) ; set untaged pointer ES:DI to point to cdr (jmps) (db sym.list.loop) ; (l sym.found) ; we have found symbol in ES:DI (mov es ax) ; return pointer in DS:AX (mov ax ds) (mov di ax) (pop es) (pop di) (jmps) (db sym.end) ; ; allocate a new symbol ; (l sym.make.new) ; (make-symbol input ()) (ss:) (mov (dw w) bx) (aw critical.f) ; check no allocation flag (and bx bx) (jz) (db sym.alloc.new) (xor ax ax) ; if no alloc then return #f (mov ax ds) (jmp) (dw sym.end) ; ; allocate new symbol ; DS:SI = input string ; ES:DI = untagged to cell to hold pair ; (l sym.alloc.new) (push es) ; push cell pointer (push di) (mov iw ax) (iw 1) ; need 1 para NOTE: check already made thus NO GC (int #x96) ; ES:DI = alloc ptr (mov es bx) ; BX:DX = new symbol (mov di dx) (mov ib dh) #x12 (cld) (mov iw ax) (iw #x0200) ; undefined (stos.w) (xor ax ax) (stos.w) (mov si ax) ; input string "print-name" (stos.w) (mov ds ax) (stos.w) (mov iw ax) (iw #x0100) ; () (stos.w) (xor ax ax) (stos.w) (int #x97) ; update alloc ptr ; ; allocate new pair ; BX:DX = new symbol ; stack = cell pointer ; (mov iw ax) (iw 1) ; need 1 para NOTE: check already made thus NO GC (int #x96) ; ES:DI = alloc ptr (mov es bp) ; BP:CX = new pair (mov di cx) (mov ib ch) #x11 (cld) (mov dx ax) ; new symbol (stos.w) (mov bx ax) (stos.w) (mov iw ax) (iw #x0100) ; () (stos.w) (xor ax ax) (stos.w) (int #x97) ; update alloc ptr ; ; BX:DX = new symbol ; BP:CX = new pair ; stack = cell pointer ; (pop si) ; DS:SI = cell pointer (pop ds) (mov cx (si w)) ; set-cell! to pair (mov bp (si db w)) 2 (mov bx ds) ; DS:AX = new symbol (mov dx ax) ; (l sym.end) ; (pop bp) ;restore frame (pop bp) (pop di) (pop es) (retf) ; ; string=symbol? ; untag input string pointer DS:SI & print name of symbol taged ES:DI ; (l str=sym?) (mov di ax) (cmp ib ah) #x12 (jz) (db sym.symok) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: Symbol table corrupted.") (l sym.symok) (push di) (push es) (xor ah ah) ; mask tags (mov ax di) (es:) (les (di db w) di) 4 ; ES:DI pointer to 2nd of symbol (call) (dw sym.s=?) ; test (string=? input symbol-string) (pop es) (pop di) (ret) ; ; string=? taged pointer DS:SI & taged pointer ES:DI ZF=#t NZ=#f ; (l sym.s=?) (push di) (push si) (push cx) (mov di ax) ; mask tags on ES:DI (xor ah ah) (mov ax di) (mov si ax) ; mask tags on DS:SI (xor ah ah) (mov ax si) (cld) (mov (si db w) cx) 2 ; cx = string length + 4 (includes typed size) (add iw cx) (iw 4) (cmps.bz cx) (pop cx) (pop si) (pop di) (ret) ; ; index symbol table vector ax=index returns: ES:DI points to stv(i) ; (l sym.index) (ss:) (les (dw w) bx) (aw sym.off) ; put taged pointer in ES:BX (xor bh bh) (mov bx di) ; ES:DI=untag pointer to symbol vector (inc ax) ; offset = 4*(1+hash-value) (add ax ax) (add ax ax) (add ax di) ; add offset to di (ret) ; ; hash function taged pointer DS:SI to string value return in AL ; (l sym.hash) (push si) (push bx) (push cx) (mov si ax) ; mask tags of DS:SI (xor ah ah) (mov ax si) (cld) (lods.w) ; check type of length (cmp iw ax) (iw #x3000) (jz) (db sym.hash.ok) (call) (dw fatal.error) (ss 13 10 "FATAL ERROR: string->symbol: bad header of string") (l sym.hash.ok) (cld) (lods.w) ; put length in cx (mov ax cx) (xor ax ax) (xor bx bx) (l sym.hash.loop) ; loop: (set! bl (xor (rotate bl 3) character)) (rol bl) (rol bl) (rol bl) (lods.b) (xor al bl) (loop) (db sym.hash.loop) (mov bx ax) ; return value in ax (pop cx) (pop bx) (pop si) (ret) ; (() ;----------------------------------------------------------------------------- ; print scheme string following call formating stack arg for: ; %d 16 bit decimal ; %k 16 bit paragraph converted to K bytes ; bashes ax, bx ;----------------------------------------------------------------------------- (l format) (pop ax) (push cx) (push dx) (push ds) (push si) (mov sp bx) ; BX = arg base (add ib bx) 8 (mov ax si) ; si=offset to string (mov cs ax) ; ds=segment to string (mov ax ds) (mov (si db w) cx) 2 ; put word length in cx (add ib si) 4 (cld) (l format.loop) (lods.b) ; AL = char (cmp ib al) #\% ; if char = % then print formatted arg (jnz) (db format.char) (lods.b) ; AL = type of format (dec cx) (cmp ib al) #\d ; %d (jnz) (db format.ck.k) (ss:) (mov (bx w) ax) ; get arg (add ib bx) 2 ; BX = next arg (call) (dw print.dec) (jmps) (db format.loop.end) (l format.ck.k) ; %k (cmp ib al) #\k (jnz) (db format.ck.?) (ss:) (mov (bx w) ax) ; get arg (add ib bx) 2 ; BX = next arg (shr ax)(shr ax)(shr ax)(shr ax)(shr ax)(shr ax) (call) (dw print.dec) (jmps) (db format.loop.end) (l format.ck.?) ; %? (ss:) (mov (bx w) ax) ; get arg (add ib bx) 2 ; BX = next arg (jmps) (db format.loop.end) (l format.char) ; print char (mov al dl) (mov ib ah) 2 (int #x21) (l format.loop.end) (loop) (db format.loop) (inc si) ; add1 for ending 0 (mov si ax) (pop si) (pop ds) (pop dx) (pop cx) (mov bx sp) ; kill args on stack (push ax) (ret) ;----------------------------------------------------------------------------- ; print scheme string following call and continue after string ; bashes ax (note: Scheme string ends with 0) ;----------------------------------------------------------------------------- (l ps.con) (pop ax) (push ds) (push dx) (push cx) (push bx) ; (mov ax bx) ; bx=offset to string (mov cs ax) ; ds=segment to string (mov ax ds) (mov (bx db w) cx) 2 ; put word length in cx (add ib bx) 4 (mov bx dx) ; dx=offset to string (mov iw bx) (iw 1) (mov iw ax) (iw #x4000) (int #x21) (mov dx ax) ; ax=return address (add cx ax) (inc ax) ; add1 for ending 0 ; (pop bx) (pop cx) (pop dx) (pop ds) (push ax) (ret) ;--------------------------------------------------------- ; print ax as decimal ;--------------------------------------------------------- (l print.dec) (push bx) (push cx) (push dx) (push di) (push ds) ; (push ax) ; (and ax ax) ;negate if minus (jns) (db decns) (neg ax) (l decns) ; setup for loop (mov cs cx) ; DS = segment to holding string (mov cx ds) (call) (iw 0) (l dec.str.base); DI = current PC (pop di) (add iw di) (aw dec.str.off); DI = DI + offset to holding string ; DS:DI = untagged to holding string (mov iw bx) (iw 10) ; constant 10 (xor cx cx) ; counter of string size (l decloop) ; loop: divide by 10; put remiander in string (xor dx dx) ; high word of number (inc cx) (dec di) (div bx) (add ib dl) #\0 (mov dl (di b)) (and ax ax) (jnz) (db decloop) (pop ax) (push ax) ; add sign to string (and ax ax) (jns) (db decpns) (dec di) (inc cx) (mov ib (di b)) #\- (l decpns) (mov iw ax) (iw #x4000) ; print result (mov di dx) (mov iw bx) (iw 1) (int #x21) ; (pop ax) ; (pop ds) (pop di) (pop dx) (pop cx) (pop bx) (ret) " " (dl dec.str.off dec.str.base) ;----------------------------------------------------------------------------- ; ERROR print message and call scheme "error" ;----------------------------------------------------------------------------- ; (() (l error) (pop ax) ; ; print message ; (mov ax bx) ; bx=offset to string (mov cs ax) ; ds=segment to string (mov ax ds) (mov (bx db w) cx) 2 ; put word length in cx (add ib bx) 4 (mov bx dx) ; dx=offset to string (mov iw bx) (iw 1) (mov iw ax) (iw #x4000) (int #x21) (int #x9e) ; call scheme error ;----------------------------------------------------------------------------- ; FATAL ERROR print message and quit ;----------------------------------------------------------------------------- ; (() (l fatal.error) (pop ax) ; (mov ax bx) ; bx=offset to string (mov cs ax) ; ds=segment to string (mov ax ds) (mov (bx db w) cx) 2 ; put word length in cx (add ib bx) 4 (mov bx dx) ; dx=offset to string (mov iw bx) (iw 1) (mov iw ax) (iw #x4000) (int #x21) (int #xa0) ; exit Scheme to DOS ;--------------------------------------------------------- ; copy code string to heap string NO call to GC ; heap.string copies string after call point ; heap.str2 copies string at DS:SI with length BP ;--------------------------------------------------------- (l heap.string) (pop si) ; DS:SI = code string (mov cs ax) (mov ax ds) (mov (si db w) bp) 2 ; BP = string length (mov si ax) ; AX = return point (add bp ax) ; = SI + header + length + 1 (for zero) (add iw ax) (iw 5) (push ax) ; put return address back (add ib si) 4 ; DS:SI = 1st char of code string (l heap.str2) (mov bp ax) ; AX = number paras needed (NO call to GC) (add iw ax) (iw 20) ; 4 for header, 1 for zero end, 15 to round up (and iw ax) (iw #xfffc) (shr ax)(shr ax)(shr ax)(shr ax) (int #x96) ; ES:DI = alloc pointer (mov bp cx) ; CX = string length (mov di dx) ; ES:DX = new string (mov ib dh) #x20 (cld) (mov iw ax) (iw #x3000) (stos.w) (mov cx ax) (stos.w) (inc cx) ; add1 for zero end (movs.b cx) ; copy string (dec di) ; make sure ending zero is zero! (xor al al) (stos.b) (add ib di) 3 ; round up alloc ptr to next long (and iw di) (iw #xfffc) (mov es ax) ; DS:AX = new string (mov ax ds) (mov dx ax) (int #x97) ; update alloc (ret) ;-------------------------------------------------------------------------int# ; print compound datum int #x95 ; DS:AX = object to be printed ;----------------------------------------------------------------------------- (l print.int) (sti) (ss:) (callf (dw w)) (aw prim.write) (iret) ;*************************************************************************** (l boot.end.init)) ;