From 3a12151067cb88b2fdde4cf00677b47f154411e4 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sat, 20 May 2023 12:57:05 +0300 Subject: [PATCH] Unpack disk2.tgz --- alink.asm | 124 ++ block.asm | 352 +++++ border.asm | 648 +++++++++ cio.asm | 1465 +++++++++++++++++++++ cprint.asm | 229 ++++ cprint1.asm | 755 +++++++++++ cread.asm | 885 +++++++++++++ cwindow.asm | 553 ++++++++ expsmmu.asm | 534 ++++++++ extsmmu.asm | 607 +++++++++ flo2hex.asm | 106 ++ get_path.asm | 205 +++ glue.asm | 32 + graphcmd.asm | 1992 ++++++++++++++++++++++++++++ graphics.asm | 3125 ++++++++++++++++++++++++++++++++++++++++++++ intrup.asm | 233 ++++ machtype.asm | 76 ++ memtype.asm | 52 + msdos.asm | 471 +++++++ msdos1.asm | 88 ++ newpcs/autocomp.s | 19 + newpcs/autoprim.s | 19 + newpcs/compile.all | 322 +++++ newpcs/edit.s | 835 ++++++++++++ newpcs/edwin.ini | 128 ++ newpcs/filepos.s | 85 ++ newpcs/graphics.s | 58 + newpcs/help.s | 206 +++ newpcs/kldscope.s | 150 +++ newpcs/oldpmath.s | 262 ++++ newpcs/padvise.s | 331 +++++ newpcs/pasm.s | 441 +++++++ newpcs/pauto_c.s | 46 + newpcs/pauto_r.s | 70 + newpcs/pboot.s | 409 ++++++ newpcs/pca.s | 271 ++++ newpcs/pchreq.s | 295 +++++ newpcs/pcomp.s | 579 ++++++++ newpcs/pdebug.s | 411 ++++++ newpcs/pdefstr.s | 210 +++ newpcs/pdos.s | 422 ++++++ newpcs/pfunarg.s | 206 +++ newpcs/pgencode.s | 790 +++++++++++ newpcs/pgr.s | 325 +++++ newpcs/pinspect.s | 368 ++++++ newpcs/pio.s | 499 +++++++ newpcs/pmacros.s | 719 ++++++++++ newpcs/pmath.s | 155 +++ newpcs/pme.s | 504 +++++++ newpcs/pnum2s.s | 395 ++++++ newpcs/popcodes.s | 707 ++++++++++ newpcs/pp.s | 542 ++++++++ newpcs/ppeep.s | 573 ++++++++ newpcs/primops.s | 275 ++++ newpcs/psimp.s | 428 ++++++ newpcs/psort.s | 135 ++ newpcs/pstd.s | 452 +++++++ newpcs/pstd2.s | 194 +++ newpcs/pstl.s | 172 +++ newpcs/pwindows.s | 265 ++++ newpcs/scpsdemo.s | 135 ++ pro2real.asm | 1707 ++++++++++++++++++++++++ probid.asm | 168 +++ prointrp.asm | 202 +++ proio.asm | 1210 +++++++++++++++++ proiosup.asm | 343 +++++ proread.asm | 821 ++++++++++++ prosmmu.asm | 268 ++++ sources/errhand.s | 73 ++ sources/extend.s | 340 +++++ sources/macros.s | 111 ++ sources/newwin.s | 158 +++ sources/stl.s | 120 ++ sources/tutframe.s | 381 ++++++ sources/tutoreng.s | 763 +++++++++++ sources/utility.s | 207 +++ xli/exec.c | 216 +++ xli/exec.doc | 72 + xli/exec.exe | Bin 0 -> 7450 bytes xli/glue_lc.asm | 32 + xli/glue_llc.asm | 32 + xli/glue_ms.asm | 33 + xli/pmath.s | 155 +++ xli/read.me | 168 +++ xli/sound.asm | 249 ++++ xli/sound.doc | 118 ++ xli/sound.exe | Bin 0 -> 946 bytes xli/trig_lc.c | 143 ++ xli/trig_lc.xli | 1 + xli/trig_llc.c | 121 ++ xli/trig_ms.c | 173 +++ xli/trig_ms.xli | 1 + xli/trig_tc.c | 233 ++++ xli/trig_tc.xli | 1 + xli/trig_tp.pas | 194 +++ xli/trig_tp.xli | 1 + 96 files changed, 34755 insertions(+) create mode 100644 alink.asm create mode 100644 block.asm create mode 100644 border.asm create mode 100644 cio.asm create mode 100644 cprint.asm create mode 100644 cprint1.asm create mode 100644 cread.asm create mode 100644 cwindow.asm create mode 100644 expsmmu.asm create mode 100644 extsmmu.asm create mode 100644 flo2hex.asm create mode 100644 get_path.asm create mode 100644 glue.asm create mode 100644 graphcmd.asm create mode 100644 graphics.asm create mode 100644 intrup.asm create mode 100644 machtype.asm create mode 100644 memtype.asm create mode 100644 msdos.asm create mode 100644 msdos1.asm create mode 100644 newpcs/autocomp.s create mode 100644 newpcs/autoprim.s create mode 100644 newpcs/compile.all create mode 100644 newpcs/edit.s create mode 100644 newpcs/edwin.ini create mode 100644 newpcs/filepos.s create mode 100644 newpcs/graphics.s create mode 100644 newpcs/help.s create mode 100644 newpcs/kldscope.s create mode 100644 newpcs/oldpmath.s create mode 100644 newpcs/padvise.s create mode 100644 newpcs/pasm.s create mode 100644 newpcs/pauto_c.s create mode 100644 newpcs/pauto_r.s create mode 100644 newpcs/pboot.s create mode 100644 newpcs/pca.s create mode 100644 newpcs/pchreq.s create mode 100644 newpcs/pcomp.s create mode 100644 newpcs/pdebug.s create mode 100644 newpcs/pdefstr.s create mode 100644 newpcs/pdos.s create mode 100644 newpcs/pfunarg.s create mode 100644 newpcs/pgencode.s create mode 100644 newpcs/pgr.s create mode 100644 newpcs/pinspect.s create mode 100644 newpcs/pio.s create mode 100644 newpcs/pmacros.s create mode 100644 newpcs/pmath.s create mode 100644 newpcs/pme.s create mode 100644 newpcs/pnum2s.s create mode 100644 newpcs/popcodes.s create mode 100644 newpcs/pp.s create mode 100644 newpcs/ppeep.s create mode 100644 newpcs/primops.s create mode 100644 newpcs/psimp.s create mode 100644 newpcs/psort.s create mode 100644 newpcs/pstd.s create mode 100644 newpcs/pstd2.s create mode 100644 newpcs/pstl.s create mode 100644 newpcs/pwindows.s create mode 100644 newpcs/scpsdemo.s create mode 100644 pro2real.asm create mode 100644 probid.asm create mode 100644 prointrp.asm create mode 100644 proio.asm create mode 100644 proiosup.asm create mode 100644 proread.asm create mode 100644 prosmmu.asm create mode 100644 sources/errhand.s create mode 100644 sources/extend.s create mode 100644 sources/macros.s create mode 100644 sources/newwin.s create mode 100644 sources/stl.s create mode 100644 sources/tutframe.s create mode 100644 sources/tutoreng.s create mode 100644 sources/utility.s create mode 100644 xli/exec.c create mode 100644 xli/exec.doc create mode 100644 xli/exec.exe create mode 100644 xli/glue_lc.asm create mode 100644 xli/glue_llc.asm create mode 100644 xli/glue_ms.asm create mode 100644 xli/pmath.s create mode 100644 xli/read.me create mode 100644 xli/sound.asm create mode 100644 xli/sound.doc create mode 100644 xli/sound.exe create mode 100644 xli/trig_lc.c create mode 100644 xli/trig_lc.xli create mode 100644 xli/trig_llc.c create mode 100644 xli/trig_ms.c create mode 100644 xli/trig_ms.xli create mode 100644 xli/trig_tc.c create mode 100644 xli/trig_tc.xli create mode 100644 xli/trig_tp.pas create mode 100644 xli/trig_tp.xli diff --git a/alink.asm b/alink.asm new file mode 100644 index 0000000..33005ec --- /dev/null +++ b/alink.asm @@ -0,0 +1,124 @@ +; =====> ALINK.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Misc Utilities * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 23 June 1985 * +;* Last Modification: 29 May 1986 * +;*************************************** + page 60,132 + +MSDOS equ 021h + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + extrn _psp:dword +ret_area db 20 dup (0) ; filename return area +dir_fnd db ' ' + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +;************************************************************************ +;* Find Match File * +;* * +;* Purpose: Given a pathname specification, which may contain wildcard * +;* characters, this routine returns the first filename in * +;* the current directory which matches the specification. * +;************************************************************************ + +find_arg struc + dw ? ; caller's ES + dw ? ; caller's BP + dw ? ; return address +filespec dw ? ; pointer to file spec (ASCIZ string) +find_arg ends + + public dir1 +dir1 proc near + push BP ; save the caller's BP + push ES + mov BP,SP ; establish local addressability + + mov AX,word ptr _psp+2 + mov ES,AX ; set ES to point to the psp + + push DS ; save DS + push ES + pop DS ; set DS to point to the psp + +; set Disk Transfer Address (DTA) to 80h in the psp + mov AH,1ah ; load "set DTA" function code + mov DX,80h ; load DTA offset + int MSDOS + pop DS ; restore DS + +; issue service call to find the first file match + mov DX,[BP].filespec ; load address of filespec in DS:DX + mov CX,10h ; set attributes to search for, + ; directories and all files except for + ; hidden and system files. + mov AH,04Eh ; load "find match file" function code + int MSDOS ; perform the service call +; if no file found, return a null string ("") + jnc dir1_ok ; if filename returned, jump +dir1_nf: xor AX,AX ; return a null pointer + jmp short dir1_ret +; copy filename found from DTA to local storage +dir1_ok: mov SI,09eh ; load offset of DTA filename area + mov DI,offset ret_area ; load address of local filename storage + cmp byte ptr ES:[SI],2eh ; don't bother with . and .. + je dir2_nxt + +dir1_x: mov AL,ES:[SI] ; load next character of filename + cmp AL,00H ; character a null string? + je dir1_y + mov [DI],AL ; and store it into return area + inc DI ; increment return area pointer + inc SI + jmp dir1_x ; if more characters, loop (jump) +dir1_y: and byte ptr ES:[95h],10h ; check for directory bit + cmp byte ptr ES:[95h],10h + jne dir_done + mov SI,offset dir_fnd ; load offset of directory message + mov CX,6 +dir1_z: mov AL,[SI] + mov [DI],AL + inc DI + inc SI + loop dir1_z +dir_done: mov byte ptr [DI],00h ; add in null byte to terminate string + mov AX,offset ret_area ; load offset of filename copy +; return to caller +dir1_ret: pop ES + pop BP ; restore caller's BP + ret ; return to caller +dir1 endp + + public dir2 +dir2 proc near + push BP ; save the caller's BP + push ES + + mov AX,word ptr _psp+2 + mov ES,AX ; set ES to point to the psp + +; issue service call to find the next file match +dir2_nxt: mov AH,04Fh ; load "step, matching files" function code + int MSDOS ; perform the service call +; if no file found, return a null string ("") + jnc dir1_ok ; if filename returned, jump + jmp short dir1_nf ; else, return filename found +dir2 endp + +prog ends + end + \ No newline at end of file diff --git a/block.asm b/block.asm new file mode 100644 index 0000000..ec8f8b6 --- /dev/null +++ b/block.asm @@ -0,0 +1,352 @@ +; =====> BASICIO.ASM +;******************************************************** +;* Scheme Runtime Support * +;* Memory Allocation Routines * +;* for Variable Length Objects * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 31 December 1987 * +;* Last Modification: * +;******************************************************** + page 60,132 + include memtype.equ + include scheme.equ + +SMALL_SIZE equ 1024 ;space in page not worth searching + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + + extrn alloc_bi:near,alloc_pa:near,garbage:near,gcsquish:near + extrn out_of_m:near + +;;;ALLOC_BLOCK +;;; +;;; calling sequence: alloc_block(reg, type, size) +;;; +;;; local storage: int temp_ret,*last_page,page,str_size +;;; +al_args struc +temp_ret dw ? ;return address from srch_block +last_page dw ? ;address of pagelink chain +page dw ? ;page # of candidate +str_size dw ? ;actual size of object +al_bp dw ? ;callers bp + dw ? ;callers es + dw ? ;return address +ret_reg dw ? ;register for return value +ob_typ dw ? ;type of object to find +ob_siz dw ? ;size of object to find +al_args ends + + public alloc_bl +alloc_bl proc near + + push es + push bp + sub sp,al_bp + mov bp,sp + +;if object is string, check for small string and adjust size appropriately + mov ax,[bp].ob_siz ;get object size + mov [bp].str_size,ax ;and save for later + cmp [BP].ob_typ,STRTYPE ;is it a string? + jnz al005 ; no, jump + cmp ax,PTRSIZE ;is it a small string? + jge al005 ; no, jump + mov [bp].ob_siz,PTRSIZE ;size = PTRSIZE +al005: + add [bp].ob_siz,BLK_OVHD ;size += BLK_OVHD + +;search page type chain for block + call srch_block + jc al050 ;jump if block found + +; Didn't find a block, test for a large block + mov ax,[BP].ob_siz + cmp ax,pagesize ;requested size > pagesize? + jb al010 ; no, jump + + public try_big +try_big: + +;try to allocate a big block + mov si,[bp].ret_reg + mov word ptr [si+02],NIL_PAGE*2 ;clear ret reg in case of GC + push ax ;size + push [BP].ob_typ ;type + push si ;return reg + call alloc_bi ;Allocate Big Block + mov sp,bp + jmp al050 ;return to caller + +;block not found in allocated pages, try to allocate a new page +al010: + push [bp].ob_typ ;type + call alloc_pa ;Allocate new page + mov sp,bp + mov [bp].page,ax ;update page + cmp ax,END_LIST ;did we succeed? + jnz al040 ; yes, jump +;no more pages, try a garbage collection, then search the pages again +;for a free block + mov si,[bp].ret_reg + mov word ptr [si+02],NIL_PAGE*2 ;clear reg before GC + call garbage ;do garbage collection + call srch_block ;search for block again + jc al050 ;return on success +; +; Still couldn't find a block large enough, try to allocate a new page once +; again (since we just did a garbage collection). +; + push [BP].ob_typ ;type + call alloc_pa ;Allocate a new page + mov sp,bp + mov [bp].page,AX ;save page number + cmp ax,END_LIST ;did we succeed? + jnz al040 ; yes, jump +; We're getting desperate now. Try a collection with compaction, then try to +; allocate a new page for the object + mov si,[bp].ret_reg + mov word ptr [si+02],0 ;clear for possible GC + call gcsquish ;Compact memory + push [bp].ob_typ ;type + call alloc_pa ;Allocate a new page + mov sp,bp + mov [bp].page,ax + cmp ax,END_LIST ;Did we succeed? + jz alloc_err ; no, out of memory +;at this point, a new page has been allocated; get a block from it +al040: + push [bp].page ;page + push [bp].ob_siz ;size + push [bp].ob_typ ;type + push [bp].ret_reg ;return reg + call find_block ;Allocate a Block + mov sp,bp + jnc alloc_err +; +; We have found a block, set up the header and return +; +al050: + cmp [bp].ob_typ,STRTYPE + jnz alloc_ret + cmp [bp].str_size,PTRSIZE + jge alloc_ret +;for small strings, put the negative value for object length + push es + mov si,[bp].ret_reg + mov bx,[si+02] ;bx = page + mov si,[si] ;si = displacement + LoadPage es,bx + mov cx,[bp].str_size + sub cx,PTRSIZE ;cx = size - PTRSIZE + mov word ptr es:[si+1],cx ;replace object length + pop es ;restore extra segment +alloc_ret: + add sp,al_bp ;remove local data + pop bp ;restore base pointer + pop es ;restore extra segment + ret ;return to caller + public alloc_err +alloc_err: + call out_of_m ;out of memory + jmp alloc_ret ;control will not return here + + +; SRCH_BLOCK - Search through all the pages of a given type looking for a +; block large enough to fill the size request. +; +; Upon Entry: All local storage and args to ALLOC_BLOCK are used. Do +; not modify BP. +; +; Upon Exit: Carry Flag set, ret_reg will contain the page:disp of the block. +; Carry Flag clear, ret_reg will contain page of -1 +; + public srch_block +srch_block label near + pop [bp].temp_ret ;save return value + + mov bx,[bp].ob_typ ;bx = object type + shl bx,1 ;make into table index + mov si,bx + add bx,offset pagelist ;bx = address of pagelist[type] + mov [bp].last_page,bx ;save in last_page + mov ax,pagelist[si] ;ax = page number for this type + cmp ax,END_LIST ;any pages to search? + clc ;carry clear = failure + jz srch_end ; no, skip loop +srch_loop: + mov [bp].page,ax ;save page number for later + + push ax ;page number + push [bp].ob_siz ;size of object + push [bp].ob_typ ;type of object + push [bp].ret_reg ;register to return value in + call find_block ;look for free space in page + mov sp,bp ;dump args off stack + jc srch_end ;carry set = success +; +; Block not found within current page. +; + mov si,[bp].page ;get page number + shl si,1 ; and make into index + cmp [bp].ob_siz,SMALL_SiZE ;size <= SMALL_SIZE? + jg sr10 ; no, jump +; less than small_size space is left within the page; this isn't worth searching +; again, so update the last position in the chain (last_page) to point to the +; next page in the chain. + mov ax,pagelink[si] ;get next page link + mov di,[bp].last_page + mov [di],ax ;*last_page = pagelink[page] +sr10: +; update last_page to contain the address of the next position in the chain, +; and get the next page from pagelink[page]. + mov bx,offset pagelink ;bx = address of pagelink table + add bx,si ;bx = address of pagelink[page] + mov [bp].last_page,bx ;save in last_page + mov ax,pagelink[si] ;get next page number + cmp ax,END_LIST ;reached end of chain? + jne srch_loop ; no, continue search for block + clc ;carry clear = failure +srch_end: + jmp [bp].temp_ret ;return to caller + +alloc_bl endp + +;;;FIND_BLOCK +;;; +;;; calling sequence: find_block(reg, type, size, page) +;;; +;;; Upon Exit: carry flag set: reg contains page:displ of new block +;;; carry flag clr: reg contains page of -1 +;;; +fb_args struc + dw ? ;callers bp + dw ? ;return address +r_reg dw ? ;register for return value +bl_typ dw ? ;block type +bl_siz dw ? ;block size +bl_pag dw ? ;page number +fb_args ends + + public find_block +find_block proc near + push bp + mov bp,sp + + mov si,[bp].r_reg ;get return register + mov Word Ptr [si+02],-1 ;default to block not found + + mov si,[bp].bl_pag ;get page number + shl si,1 ;si = page index + LoadPage es,si ;es => page + +; lets see if there's space in the free pool of this block + mov bx,nextcell[si] ;bx = next cell in page + cmp bx,END_LIST ;if no more space + jz fb015 ; then jump + mov ax,es:[bx+1] ;ax = free pool size + mov dx,[bp].bl_siz ;get size required + cmp ax,dx ;if not enough space in pool + jl fb015 ; then jump + +; allocate a block from the free pool. +; ax = free pool size, bx = displacement, dx = object size + mov cx,[bp].bl_typ ;cx = type of object + mov byte ptr es:[bx],cl ;store type of new object + mov word ptr es:[bx+1],dx ;store size of new object + mov di,bx ;cx = displacement + add di,dx ;di = new displacement + mov cx,psize[si] ;get page size + sub cx,BLK_OVHD ; and subtract block overhead + cmp cx,di ;next displ still in page? + jb fb010 ; no, jump + mov byte ptr es:[di],FREETYPE ;mark next area as free + sub ax,dx ;ax = pool size - object size + mov word ptr es:[di+1],ax ;update free pool size + mov nextcell[si],di ;update nextcell chain + jmp fb045 ;return to caller +fb010: + mov nextcell[si],END_LIST ;nextcell[page] = END_LIST + jmp fb045 ;return to caller + +; A block was not found in the free pool. Search the entire block for a fragment +; to satisfy the request. +fb015: + xor bx,bx ;bx = displacement + mov cx,psize[si] + sub cx,[bp].bl_siz ;cx = displacement threshold + cmp cx,bx ;threshhold >= displacement? + clc ;zero flag not set = failure + jl fb050 ;return with no block found + +;the following loop requires bx=displacement, cx=threshold, dx=free size +fb020: + mov dx,word ptr es:[bx+1] ;dx = size of object + cmp byte ptr es:[bx],FREETYPE ;is next area free? + jz fb035 ; yes, jump +fb025: mov ax,BLK_OVHD+PTRSIZE ;ax = ovhd for small string + test dx,dx ;if size negative + js fb030 ; then jump + mov ax,dx ; else ax = size of object +fb030: add bx,ax ;displacement += size + cmp cx,bx ;if disp <= threshhold + jge fb020 ; then go look at next object + clc ;zero flag not set = failure + jmp fb050 ;return with no block found + +;we have found a free space in the block; if not big enough then jump back +;into loop above, otherwise allocate the new storage +fb035: + mov ax,[bp].bl_siz + cmp ax,dx ;compare size to free size + jl fb025 ;if less, return to loop + jnz fb040 ;if not equal, jump +; we found an exact match + mov ax,[bp].bl_typ + mov byte ptr es:[bx],al ;just update the type field + jmp fb045 ;and return to caller +fb040: + mov di,dx + sub di,BLK_OVHD ;di = free size - block overhead + cmp di,ax ;can object fit into free space? + jle fb025 ; no, return to loop +; we can fit into a larger block, split block to allocate storage + mov cx,[bp].bl_typ ;cx = type of object + mov byte ptr es:[bx],cl ;store type of new object + mov word ptr es:[bx+1],ax ;store size of new object +;ax=new object size, bx=disp, dx= free size + mov di,bx + add di,ax ;di = new displacement + mov cx,dx + sub cx,ax ;cx = free size - new size + mov byte ptr es:[di],FREETYPE ;mark next area as free + mov word ptr es:[di+1],cx ;update next area free size +; +; block found; return page,disp in return register. +; si = page index, bx = displacement +fb045: + mov ax,si ;ax = page index + mov si,[bp].r_reg ;si = address of return reg + mov [si+02],ax ;put page index in register + mov [si],bx ;put diplacement in register + stc ;carry set = success +fb050: + pop bp ;restore base pointer + ret ;return to caller + +find_block endp + +prog ends + END + \ No newline at end of file diff --git a/border.asm b/border.asm new file mode 100644 index 0000000..0688ac6 --- /dev/null +++ b/border.asm @@ -0,0 +1,648 @@ +; =====> BORDER.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* Window Support Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 16 May 1985 * +;* Last Modification: * +;* 14 April 1986 : * +;* Make references to pagetabl * +;* call Memory Manager for use * +;* with extended/expanded mem. * +;* 26 Sept 1986 : * +;* added EGA support * +;* 13 May 1987 : * +;* Fixed Save/restore problem. * +;*************************************** + page 60,132 + include scheme.equ + include pcmake.equ + +MSDOS equ 021h +TI_CRT equ 049h +IBM_CRT equ 010h + + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + extrn MAX_ROWS:byte,MAX_COLS:byte + + +; ___ __ __ +; + -| |- _|_ | -- | __| |__ | | (extra) +map_tab db 0c5h,0b4h,0c3h,0c1h,0c2h,0c4h,0b3h,0d9h,0c0h,0bfh,0dah,0dah +map_tabx equ $ + +trns_tab db 0dah,0c2h,0c3h,0c5h,0c3h,0c2h,0c2h,0c5h,0c3h,0c5h,0c5h + db 0c2h,0bfh,0c5h,0b4h,0b4h,0c2h,0c2h,0c5h,0c5h,0b4h,0c5h + db 0c3h,0c5h,0c0h,0c1h,0c3h,0c1h,0c5h,0c1h,0c3h,0c5h,0c5h + db 0c5h,0b4h,0c1h,0d9h,0b4h,0c1h,0c5h,0c1h,0c5h,0b4h,0c5h + db 0c3h,0b4h,0c3h,0b4h,0b3h,0c5h,0c5h,0c5h,0c3h,0b4h,0c5h + db 0c2h,0c2h,0c1h,0c1h,0c5h,0c4h,0c2h,0c1h,0c5h,0c5h,0c5h + +m14_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 1,0,2,2,1,4,2,0,0,3,3,7,3,5,6,2,6,6,5,3,5,2,1,2,2,1,7,3 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 2,6,1,2,2,0,3,0,0,0,3,1,0,4,0,0,1,1,3,0,3,0,2,0,1,3,1,1 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 0,1,0,0,0,3,7,1,5,0,3,4,3,3,3,0,6,6,0,0,2,2,3,2,3,2,3,2 + +;117-126 u v w x y z { | } ~ + db 2,3,3,2,2,2,3,1,0,1 + +;127-191 + db 64 dup (0) + +;192-197 + db 5,2,0,0,0,4 + +;198-218 + db 20 dup (0) +;219-220 + db 2,5 + +m16_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 3,1,4,4,4,7,4,2,2,6,6,11,6,9,9,4,10,10,9,6,9,4,2,4,4,3,10,6 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 5,10,3,4,5,2,5,2,2,2,5,2,2,8,2,2,2,2,5,2,5,2,4,2,2,5,2,2 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 2,2,2,2,2,3,12,2,9,2,6,7,6,6,6,2,10,11,2,2,5,5,6,5,6,5,6,4 + +;117-126 u v w x y z { | } ~ + db 5,5,5,5,5,5,6,2,2,3 + db 64 dup (0) + db 7,2,0,0,0,7 + db 20 dup (0) + db 2,7 + + public m18_attr +m18_attr equ $ +;33-60 ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < + db 2,1,4,4,8,8,4,2,2,6,6,10,9,10,05,4,10,10,10,6,10,4,2,4,4,10,10,6 + +;61-88 = > ? @ A B C D E F G H I J K L M N O P Q R S T U V W X + db 9,06,2,4,4,2,6,2,2,2,6,2,2,8,2,2,2,2,6,2,6,2,4,2,2,6,2,2 + +;89-116 Y Z [ \ ] ^ _ ` a b c d e f g h i j k l m n o p q r s t + db 2,2,2,3,2,3,13,2,10,2,6,8,6,6,6,2,10,12,2,2,5,5,6,5,6,5,6,4 + +;117-126 u v w x y z { | } ~ + db 5,6,6,5,5,5,6,2,2,2 + db 64 dup (0) + db 10,4,0,0,0,8 + db 20 dup (0) + db 8,8 + +last_char db 0dbh + + extrn char_hgt:byte + extrn vid_mode:word +data ends + +XGROUP group PROGX +PROGX segment byte public 'PROGX' + assume CS:XGROUP + +;************************************************************************ +;* Perform appropriate VIDEO I/O interrupt * +;* Any difference in register definition should be handled by * +;* the caller except where DH,DL contain row,col information. * +;************************************************************************ + public crt_dsr +crt_dsr proc far + cmp PC_MAKE,TIPC + jne ibm_dsr + int TI_CRT + ret +ibm_dsr: xchg DH,DL ; Do this now instead of making special checks + int IBM_CRT ; IBM's row,col is diff'rnt from TI's col,row + ret +crt_dsr endp + +;************************************************************************ +;* Draw Border * +;************************************************************************ +zb_args struc + dw ? ; caller's BP + dd ? ; return address (far linkage) + dw ? ; return address (original) +zb_line dw ? ; upper left corner line number +zb_col dw ? ; upper left corner column number +zb_nlines dw ? ; number of lines +zb_ncols dw ? ; number of columns +zb_battr dw ? ; border attributes +zb_label dw ? ; pointer to label text +zb_args ends + + public z%border +z%border proc far + push BP ; save caller's BP + mov BP,SP + +; output corners + mov BL,byte ptr [BP].zb_battr ; load attribute bits + mov DH,byte ptr [BP].zb_col ; load left column number + mov DL,byte ptr [BP].zb_line ; load left line number + dec DL + dec DH + mov AL,0DAh ; load upper left corner character + call zcorner + inc DH + add DH,byte ptr [BP].zb_ncols + mov AL,0BFh ; load upper right corner character + call zcorner + inc DL + add DL,byte ptr [BP].zb_nlines + mov AL,0D9h ; load lower right corner character + call zcorner + dec DH + sub DH,byte ptr [BP].zb_ncols + mov AL,0C0h ; load lower left corner character + call zcorner + +; output sides + mov DH,byte ptr [BP].zb_col ; reload upper left column number + mov DL,byte ptr [BP].zb_line ; and line number + dec DH ; decrement column number + mov CX,[BP].zb_nlines + call zside ; draw the left hand border + mov DH,byte ptr [BP].zb_col ; reload upper left column number + mov DL,byte ptr [BP].zb_line ; and line number + add DH,byte ptr [BP].zb_ncols ; add in line length + mov CX,[BP].zb_nlines + call zside ; draw the right hand border + +; Output the top of the border + mov DL,byte ptr [BP].zb_line ; load upper left row number + dec DL + jl z_no_top ; if row negative, skip write + mov DH,byte ptr [BP].zb_col ; load upper left column number + mov CX,[BP].zb_ncols + call ztop +; Put the label in the top left corner of the border, if it'll fit + mov BX,[BP].zb_label ; load pointer to the label's text + cmp BX,0 ; if pointer NULL, no label + je z_no_top ; jump, if NULL pointer + mov DX,[BP].zb_ncols ; load window width + xor CX,CX ; zero the character counter +zb_loop: cmp byte ptr [BX],0 ; end of string? + je zb_eos ; if end of string, jump + inc CX ; increment the character count + inc BX ; increment the character string pointer + cmp CX,DX ; compare to window width + jl zb_loop ; if label still shorter than window, loop +zb_eos: jcxz z_no_top ; if no label, jump + push CX ; save label length +; Write the label + mov DL,byte ptr [BP].zb_line ; load upper left row number + mov DH,byte ptr [BP].zb_col ; load upper left column number + dec DL ; decrement row number + xor BH,BH ; IBMism (page 0 for text-mode) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; put cursor in upper left corner of border + pop CX ; restore label's character count + cmp PC_MAKE,TIPC + jne ibm_cblk + mov AH,011h ; load "write block of characters" code + mov DX,DS ; load segment address + mov BX,[BP].zb_label ; load label offset + int TI_CRT ; write the label + jmp short z_no_top +; +ibm_cblk: mov AL,byte ptr [BP].zb_col + add AL,CL + cmp AL,MAX_COLS + jle zb_sml ; jump if label length is OK + sub AL,MAX_COLS + sub CL,AL ; force label to remain within 80-col screen +zb_sml: mov DI,[BP].zb_label ; load label offset +lbl_loop: mov AH,0Eh ; Write ASCII Teletype + mov AL,byte ptr [DI] + mov BL,byte ptr [BP].zb_battr ; load attribute bits just in case + xor BH,BH ; page # for alpha mode + push CX + push DI + int IBM_CRT + pop DI + pop CX + inc DI + loop lbl_loop ; DECrement CX and jump if != 0 +; Output the bottom of the border +z_no_top: mov BL,byte ptr [BP].zb_battr ; load attribute bits + mov DL,byte ptr [BP].zb_line + add DL,byte ptr [BP].zb_nlines + mov DH,byte ptr [BP].zb_col ; load upper left column number + mov CX,[BP].zb_ncols + call ztop + +; return to caller + pop BP ; restore caller's BP + ret ; return +z%border endp + +;************************************************************************ +;* Local Support: Draw a single character at cursor position * +;* * +;* Input Registers: AL - the character to be output * +;* BL - the character attributes for the write * +;* DH - column * +;* DL - row * +;* * +;* Registers Modified: AX,CX,SI,DI * +;************************************************************************ +zcorner proc near ; draw a single corner character + cmp DH,MAX_COLS + jae zcornret + cmp DL,MAX_ROWS + jae zcornret + push DX ; save cursor coordinates + push AX ; save character to be output + xor BH,BH ; page number (=0 for graphics mode also) + mov AH,02h ; load "put cursor" code + call CRT_DSR ; position the cursor +; read the character in this screen position +; ** This is tricky 'cause DH/DL are correct but +; ** will be swapped back (to incorrect) by CRT_DSR proc +; ** if using an IBM!!! + cmp PC_MAKE,TIPC + je no_swap + xchg DH,DL + xor BH,BH ; IBM display page +no_swap: mov AH,08h + call CRT_DSR +; see if it's one of the borderline characters + call map_char + mov SI,AX + pop AX ; recover character to be output + cmp SI,0 + jl zcornput +; map corner to border character + call map_char + mov DL,map_tabx-map_tab-1 + mul DL + add SI,AX + mov AL,trns_tab+[SI] +; output the corner character +zcornput: mov AH,09h ; load "write character/attribute" code + mov CX,1 ; number of characters = 1 + xor BH,BH ; Display page for IBM text mode (=0) + call CRT_DSR ; write it to the screen at cursor position + pop DX ; restore cursor coordinates +zcornret: ret ; return +zcorner endp + +;************************************************************************ +;* Local Support: Draw a border sides * +;* * +;* Input Registers: DH - column * +;* DL - row * +;* CX - number of rows * +;* * +;* Registers Modified: AX,CX,DL * +;************************************************************************ +zside proc near + cmp DH,MAX_COLS ; is column within the CRT's boundaries? + jae zsideret ; if not, jump +zside_lp: mov AL,0B3h ; load "|" border character + push CX ; save line count + push DX ; save next cursor position + call zcorner ; output the border character + pop DX ; restore current cursor position + pop CX ; restore line counter + inc DL ; increment the row number + loop zside_lp ; loop until side is drawn +zsideret: ret +zside endp + +;************************************************************************ +;* Local Support: Draw a border - Top or Bottom * +;* * +;* Input Registers: DH - column * +;* DL - row * +;* CX - number of columns * +;* * +;* Registers Modified: AX,CX * +;************************************************************************ +ztop proc near + cmp DL,MAX_ROWS ; is row within the CRT's boundaries? + jae ztopret ; if not, jump +ztop_lp: mov AL,0C4h ; load "-" border character + push CX ; save line count + push DX ; save next cursor position + call zcorner ; output the border character + pop DX ; restore current cursor position + pop CX ; restore line counter + inc DH ; increment the column number + loop ztop_lp ; loop until top/bottom is drawn +ztopret: ret +ztop endp + +map_char proc near + mov CX,map_tabx-map_tab + mov DI,offset map_tab +repne scasb + mov AX,CX + dec AX + ret +map_char endp + +;************************************************************************ +;* Save Screen Contents * +;* * +;* Purpose: To save a rectangular region of the CRT in a string data * +;* object. * +;* * +;* Calling Sequence: save_scr(str_reg, ul_row, ul_col, n_rows, ncols) * +;* where str_reg - pointer to string data object * +;* which is to receive the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* saved * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* saved * +;* n_rows - number of rows in the region to * +;* be saved * +;* n_cols - number of columns in the region * +;* to be saved * +;************************************************************************ +sv_args struc + dw ? ; caller's BP + dw ? ; caller's ES + dd ? ; return address (long) +; dw ? ; original return address (short) +sv_str dw ? ; address of register pointing to string +sv_ulrow dw ? ; upper left hand corner's row number +sv_ulcol dw ? ; upper left hand corner's column number +sv_nrow dw ? ; number of rows +sv_ncol dw ? ; number of columns +sv_args ends + + public save%scr +save%scr proc far + push ES + push BP ; save the caller's BP register + mov BP,SP ; and establish local addressability +; create a pointer to the string object + mov BX,[BP].sv_str ; load address of register + mov DI,[BX].C_disp ; load the string + mov BX,[BX].C_page ; pointer + %LoadPage ES,BX ; load string page's paragraph address +;;; mov ES,pagetabl+[BX] ; load string page's paragraph address + add DI,BLK_OVHD ; advance pointer past string header +; store number of rows and columns into the first two bytes of the string + mov AL,byte ptr [BP].sv_nrow + stosb + mov AL,byte ptr [BP].sv_ncol + stosb +; adjust number of lines/columns for test conditions + mov AX,[BP].sv_ulrow + add [BP].sv_nrow,AX + mov AX,[BP].sv_ulcol + add [BP].sv_ncol,AX +; loop until all rows processed + mov DL,byte ptr [BP].sv_ulrow +rw_loop: mov DH,byte ptr [BP].sv_ulcol +; position cursor +cl_loop: push DX ; save current position + mov AH,02h ; load "put cursor" function id + xor BH,BH ; IBMism (page number for cursor) + call crt_dsr ; position the cursor +; read character/attributes at current screen position + mov AH,08h ; load "read char/attribute" function id + xor BH,BH ; IBMism (display page #) + call crt_dsr ; read said +;******* + cmp vid_mode,14 + jl sav_01 ; not graphics modes + cmp AL,0 ; don't bother with attributes if nul + je sav_01 +; cmp AL,07fh ; is it above the first 128 characters ? +; jno sav_00 ; no + cmp AL,0dah + jbe sav_00 +; test AL,010h ; look for D0-DF +; je sav_00 + xor AL,AL ; set to nul + jmp sav_01 +sav_00: call graph_attr ; mode 14,16, and 18 attribute function +;****** +sav_01: stosw ; store char/attr into output string +; increment column number, test, branch + pop DX + inc DH + cmp DH,byte ptr [BP].sv_ncol + jl cl_loop +; increment row number, test, branch + inc DL + cmp DL,byte ptr [BP].sv_nrow + jl rw_loop + +; return to caller + pop BP + pop ES + ret ; return to caller +save%scr endp + +;************************************************************************ +;* Restore Screen Contents * +;* * +;* Purpose: To restore a rectangular region of the CRT from a string * +;* data object. * +;* * +;* Calling Sequence: rest_scr(str_reg, ul_row, ul_col) * +;* where str_reg - pointer to string data object * +;* which contains the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* restored * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* restored * +;************************************************************************ +rs_args struc +rs_nrow dw ? ; number of rows in saved data +rs_ncol dw ? ; number of columns in saved data +rs_BP dw ? ; caller's BP + dw ? ; caller's ES + dd ? ; return address (long) +; dw ? ; original return address (short) +rs_str dw ? ; address of register pointing to string +rs_ulrow dw ? ; upper left hand corner's row number +rs_ulcol dw ? ; upper left hand corner's column number +rs_mrow dw ? ; number of rows in new window +rs_mcol dw ? ; number of columns in new window +rs_args ends + + public rest%scr +rest%scr proc far + push ES + push BP ; save the caller's BP register + sub SP,offset rs_BP + mov BP,SP ; and establish local addressability +; create a pointer to the string object + mov BX,[BP].rs_str ; load address of register + mov SI,[BX].C_disp ; load the string + mov BX,[BX].C_page ; pointer + %LoadPage ES,BX ; load string page's paragraph address +;;; mov ES,pagetabl+[BX] ; load string page's paragraph address + add SI,BLK_OVHD ; advance pointer past string header +; recover number of rows and columns from screen object + xor AX,AX + lods byte ptr ES:[SI] + add AX,[BP].rs_ulrow + mov [BP].rs_nrow,AX + lods byte ptr ES:[SI] + add AX,[BP].rs_ulcol + mov [BP].rs_ncol,AX +; adjust number of lines/columns for test conditions + mov AX,[BP].rs_ulrow + add [BP].rs_mrow,AX + mov AX,[BP].rs_ulcol + add [BP].rs_mcol,AX +; loop until all rows processed + mov DL,byte ptr [BP].rs_ulrow +xw_loop: mov DH,byte ptr [BP].rs_ulcol +; position cursor +xl_loop: cmp DH,byte ptr [BP].rs_mcol ; column too long for new window? + jge x_long ; if too long, jump + push DX ; save current position + mov AH,02h ; load "put cursor" function id + xor BH,BH ; IBMism (page number/0 in graphic mode) + call crt_dsr ; position the cursor +; read character/attributes at current screen position + lods word ptr ES:[SI] ; fetch the character and attribute + +;;;;;;;; cmp AL,20h +;;;;;;;; je x_sp ; if a space skip + + mov BL,AH ; and copy attribute to BL + mov AH,09h ; load "write char/attribute" function id + xor BH,BH ; IBMism (page number) + mov CX,1 ; character count = 1 + call crt_dsr ; read said +; increment column number, test, branch +x_sp: pop DX ; recover the row/column coordinates +x_more: inc DH ; increment the column number + cmp DH,byte ptr [BP].rs_ncol ; more characters in this row? + jl xl_loop ; if so, jump +; increment row number, test, branch + inc DL ; increment the row number + cmp DL,byte ptr [BP].rs_mrow ; check against new window boundary + jge rs_fin ; if all rows filled, jump + cmp DL,byte ptr [BP].rs_nrow ; check against saved data + jl xw_loop ; if more lines, jump + +; return to caller +rs_fin: add SP,offset rs_BP ; deallocate local storage + pop BP ; restore the caller's BP register + pop ES ; restore the caller's ES register + ret ; return to caller +; +x_long: inc SI ; increment index into saved screen + inc SI ; buffer + jmp short x_more ; continue processing row +rest%scr endp + +;************************************************************************ +;* Graphics Character Attribute * +;* * +;* Purpose: To retrieve the attribute of a character on an IBM screen * +;* in a graphics mode, either 14 or 16. * +;* * +;************************************************************************ + + public graph_attr +graph_attr proc near + + cmp AL,20h ; skip if a space + je grphend + + cmp AL,00h ; skip if a null + je grphend + + cmp AL,0dbh ; block character? + je grphend + + push ES + push SI + push AX ; save character + push DX ; save row and column + xor AH,AH ; clear AH + mov SI,AX ; use SI as an index + sub SI,21h + + mov AL,DL ; row + mul char_hgt ; pixels per character + xor BX,BX + + mov BL,byte ptr m18_attr[SI] ; default mode 18 adjustment + cmp vid_mode,18 ; are we in mode 18? + je grph_02 ; yes, jump + mov BL,byte ptr m16_attr[SI] ; default mode 16 adjustment + cmp vid_mode,16 ; are we in mode 16? + je grph_02 ; yes, jump + mov BL,byte ptr m14_attr[SI] ; must be mode 14 +grph_02: + add AX,BX + mov BX,80 ; 80 bytes per line + mul BX + + pop DX ; restore the column + xor DL,DL ; clear the row + xchg DH,DL ; set AX to the row + add AX,DX + mov SI,AX ; put result in SI + + mov AX,0a000h ; load in graphics plane + mov ES,AX + xor CX,CX ; clear CX + + mov CH,01 + mov AH,0 +grph_03: call get_val + + shl CH,1 ; shift mask one bit to the left + inc AH ; next plane + cmp AH,3 + jbe grph_03 + + pop AX ; retrieve character + mov AH,CL ; set attribute byte + pop SI + pop ES +grphend: ret +graph_attr endp + +get_val proc near + push AX ; save AH + mov DX,3ceh ; port addr of sequencer + mov AL,04h ; index to other map mask register + out DX,AL ; set index register + inc DX + xchg AL,AH + out DX,AL ; enable bank + pop AX ; restore AH + mov AL,ES:[SI] + or AL,AL + jz get_end + or CL,CH ; set attribute bit +get_end: ret +get_val endp + +PROGX ends + end + \ No newline at end of file diff --git a/cio.asm b/cio.asm new file mode 100644 index 0000000..89c68a6 --- /dev/null +++ b/cio.asm @@ -0,0 +1,1465 @@ +; =====> CIO.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* I/O support * +;* * +;* (C) Copyright 1985, 1986 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* Last Modification: * +;* 14 April 1986 * +;* Change references to pagetabl * +;* to call memory manager for use * +;* with extended/expanded mem. * +;* 9 Sept 1986 - ds * +;* Add EGA support * +;* 21 Nov 1986 - rb * +;* Detect disk full error correctly* +;* 7 Jan 1987 - dbs * +;* Added support for random I/O * +;* 10 Feb 1987 - tc * +;* EOF-DISP modified to reflect * +;* other changes in Page 5 symbols * +;* 16 Mar 1987 - tc * +;* Added Binary I/O, Error handling* +;* for Disk Full * +;* 21 Jan 1988 - rb * +;* binary I/O uses line-length=0; * +;* do EGA cursor with BIOS call; * +;* use dirty bit of port flags * +;* (commented out) * +;* * +;*************************************** + page 60,132 + include scheme.equ + include sinterp.arg + +P_FLAGS equ 6 +W_FLAGS equ 26 +HANDLE equ 8 +CUR_LINE equ 10 +CUR_COL equ 12 +UL_LINE equ 14 +UL_COL equ 16 +N_LINES equ 18 +N_COLS equ 20 +T_ATTR equ 24 +BUF_POS equ 28 +BUF_END equ 30 +BUFR equ 32 +CHUNK equ 14 +BACKSP equ 08 +WRAP equ 1 +TAB equ 09 +RETURN equ 0Dh +LF equ 0Ah +CTRL_Z equ 1Ah +LEFT_AR equ 4Bh +RIGHT_AR equ 4Dh +F3 equ 3Dh +F5 equ 3Fh +INSERT equ 52h +DELETE equ 53h +ENTER equ 0Dh +NULL_CH equ 0 +BELL_CH equ 07 +BLANK equ 0020h +buf_len equ 253 +MSDOS equ 21h + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public port_r, port_seg, port_d + public prn_hand + public direct,nlines, ncols, ulline, ulcol + public curcol, row, column, cur_off, char_hgt +bad_set db "[VM INTERNAL ERROR] setadr: bad port",CR,LF,0 +push_er db "[VM INTERNAL ERROR] pushchar: failed",CR,LF,0 +rd_st_er db "[VM INTERNAL ERROR] takechar: source not a string",CR,LF,0 +ch_rd db "CHAR-READY?",0 +rch_er db "READ-CHAR",0 +sfp_err db "SET-FILE-POSITION!",0 +port_r dw 0 ; port_reg + dw 0 +port_seg dw 0 ; port_page segment +port_d dw 0 ; port_disp +prn_hand dw 0 ; printer handle +win_p dw 0 ; window_p +str_p dw 0 ; string_p +handlee dw 0 ; handle +direct dw 0 ; direction +nlines dw 0 ; n_lines +ncols dw 0 ; n_cols +ulline dw 0 ; ul_line +ulcol dw 0 ; ul_col +t_attrib dw 0 ; text attribute +insert_m dw 0 ; insert mode +curcol dw 0 ; cur_col +curline dw 0 ; cur_line +index dw 0 ; index of buffer +sh_ptr dw 0 ; pointer of shadow buffer +sh_len dw 0 ; length of shadow buffer +sh_bufer db 256 dup (0) ; shadow buffer for characters +row dw 256 dup (0) ; row vector +column dw 256 dup (0) ; column vector + +scan dw ? +endscan dw ? +cur_off dw 0 +char_hgt dw 8 + + extrn vid_mode:word + extrn ega_col:byte + extrn ega_row:byte + +data ends + +XGROUP group progx +progx segment word public 'progx' + assume CS:XGROUP + + extrn zbell:far + extrn zch_rdy:far + extrn sch_err:near + extrn dos_err:near +; +; For the Ega +; This routine first outputs a byte to the sequencer register to point to +; the map mask register, and then uses the map mask register to enable +; all banks for writing. +; + public enable +enable proc far + comment ~ + push DX + push AX + mov DX,3c4h ; port addr of sequencer + mov AL,2 ; index to other map mask register + out DX,AL ; set index register + inc DX ; set DX to map mask register + xchg AL,AH + out DX,AL ; enable all banks + pop AX + pop DX + ~ + ret +enable endp + +;**************************************************************************** +;* * +;* EGA Cursor Emulator * +;* * +;* Purpose: to simulate a cursor for the IBM EGA modes. * +;* * +;**************************************************************************** + public ega_curs +ega_curs proc far + + cmp vid_mode,14 ; don't bother unless in EGA mode + jl ega_03 + + mov CX,cur_off + and CX,7fh ; is bit one on? + jz ega_02 ; cursor not turned off + and cur_off,0feh ; turn off bit one + jmp ega_03 + +ega_02: cmp t_attrib,00h ; black attribute? + je ega_03 ; forget it + +; set up BIOS call + mov AX,09DBh ; reverse-video block + mov BX,8Fh ; attr = xor,white + mov CX,1 ; repetition count = 1 + int 10h + + comment ~ + push ES + mov AX,0a000h + mov ES,AX + + mov char_hgt,8 + cmp vid_mode,14 + je ega_01 + mov char_hgt,14 +; +; start scan line = row * height +; +ega_01: mov AL,ega_row ; current line number + xor AH,AH + mul char_hgt + mov scan,AX +; +; end scan line = row * height + height - 1 +; + add AX,char_hgt + dec AX + mov endscan,AX + +show_loop: + mov CX,80 + mul CX + mov BX,AX + xor AX,AX + mov AL,ega_col + add BX,AX ; current column + mov AH,18h + call logical + mov DL,0ffh + call clrbyte + inc scan + mov AX,scan + cmp AX,endscan + jl show_loop + mov AH,0 + call logical + mov AH,0 + call enable + pop ES + ~ + +ega_03: ret +ega_curs endp + + comment ~ +; signal to the graphics processor that we want to do a logical operation +; (and or xor) with the latched data. +; on entry ah = function selected +logical proc near + push DX + push AX + mov DX,3ceh ; port addr of graphics address reg + mov AL,3 ; data rotate function + out DX,AL + inc DX + xchg AL,AH + out DX,AL + pop AX + pop DX + ret +logical endp +; +;on entry: DL contains bit mask for clearing ES:[BX] points to byte in +; CRT memory +; +clrbyte proc near + mov AH,0fh + call enable ; enable all banks + mov AL,ES:[BX] ; latch data + xor AL,AL ; zero + mov ES:[BX],AL ; clear byte + mov AH,0ffh + call enable + mov AL,ES:[BX] ; ???? + mov AL,DL ; bit mask for character + mov ES:[BX],AL ; set the value + ret +clrbyte endp + ~ + +progx ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + extrn zscroll:near + extrn zputcur:near + extrn zputc:near + extrn getch:near + extrn zcuron:near + extrn zcuroff:near + extrn zread:near + extrn toblock:near + extrn stringrd:near + extrn printstr:near + +;******************************************************************** +; * +; set_pos will set the file position, determing which chunk * +; of the file to read and then setting the file position to * +; the appropriate place. * +; * +;******************************************************************** + +set%_arg struc + dw ? ; caller's CS and IP + dw ? + dw ? ; ES +set_prt dw ? ; port # +set_amt dw ? ; chunk # +set_buf dw ? ; new buffer pointer +set%_arg ends + + public set_pos +set_pos proc near + + push ES + push BP + mov BP,SP + mov AX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + mov BX,tmp_page ; check return status + cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type + je set_010 +setferr: lea BX,sfp_err ; address of error message + pushm <[BP].set_buf, [BP].set_amt, [BP].set_prt> + mov AX,3 + pushm + C_call set_src_,,Load_ES ; set_src_err + mov SP,BP + mov AX,-1 + jmp set_don +; +set_010: mov BX,tmp_page + LoadPage ES,BX ; get page address of port + mov SI,tmp_disp + mov DX,word ptr ES:[SI+P_FLAGS] + and DX,04h ; port a file or a window? + cmp DX,04h + je setferr + + mov DI,[BP].set_amt + mov DX,[DI] + inc DX + mov word ptr ES:[SI+CHUNK],DX ; update chunk # + dec DX + mov CL,8 + xor BX,BX + mov BL,DH + xor DH,DH + shl DX,CL ; multiply DX by 256 + mov CX,BX + + test byte ptr ES:[SI+P_FLAGS],READWRITE+WRITE_ONLY ;test port flags + pushf ;save flags for later + jz set_015 ;if input port jump + or byte ptr ES:[SI+P_FLAGS],DIRTY ;else set dirty bit + mov BX,[BP].set_buf ; get chunk offset + add DX,[BX] ; and add fo file position +set_015: + mov BX,word ptr ES:[SI+HANDLE] ;get file handle + mov AH,42h ;move file pointer to file + mov AL,0 ;start plus offset in dx + int MSDOS + popf ;restore flags + jnz set_020 ;jump if output port + + mov CX,256 ;get buffer length + mov BX,word ptr ES:[SI+HANDLE] ;get file handle + mov DX,SI + add DX,32 ;start of port buffer + push DS + push ES + pop DS ;ds:dx => port buffer + mov AH,3fh ;read from a file + int MSDOS ;go do it + pop DS + mov word ptr ES:[SI+BUF_END],AX ;save #bytes read in port +set_020: + mov BX,[BP].set_buf ;address of chunk offset + mov AX,[BX] ;get offset + mov word ptr ES:[SI+BUF_POS],AX ;and save in port + +set_don: pop BP + pop ES + ret +set_pos endp +;;;************************************************************************** +;;; Set Port Address +;;;************************************************************************** +set_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +pg dw ? ; adjusted page number +dis dw ? +set_arg ends + public ssetadr ; temporary +ssetadr proc near ; assembly routine for setadr + push ES + push BP + mov BP,SP + push DI + push SI + push BX + mov BX,[BP].pg ; adjusted page number + cmp byte ptr ptype+[BX],PORTTYPE*2 ; check port type + jne set_err +; get port information + lea DI,port_r ; get port register address + mov [DI].C_page,BX + mov SI,[BP].dis + mov [DI].C_disp,SI + mov port_d,SI + LoadPage ES,BX ; get page address +;;; mov ES,word ptr pagetabl+[BX] ; get page address + mov port_seg,ES ; save the page paragraph + mov AX,word ptr ES:[SI+HANDLE] ; handler + mov handlee,AX + mov AX,word ptr ES:[SI+P_FLAGS] ; port flag + mov direct,AX + mov BX,AX + and AX,WINDOW + mov win_p,AX + and BX,STRIO + mov str_p,BX + xor AX,AX ; return status +set_ret: pop BX + pop SI + pop DI + pop BP + pop ES + ret +; Display error message +set_err: lea SI,bad_set ; address of error message + push SI + C_call printf,,Load_ES ; print error message + mov SP,BP + C_call force_de ; force_debug + mov SP,BP + mov AX,1 ; return error status + jmp set_ret +ssetadr endp +;;;************************************************************************** +;;; Input a Single Character +;;;************************************************************************** +take_arg struc +leng dw 256 +new_bpos dw 0 +take_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +take_arg ends + public take_ch +take_ch proc near + push ES + push BP + sub SP,offset take_BP ; allocate local storage + mov BP,SP + mov [BP].new_bpos,0 ; buf position after refilling buf + mov [BP].leng,256 ; set up buffer length + lea SI,port_r + mov BX,[SI].C_page + LoadPage ES,BX + mov SI,port_d ; get displacement + +; Fix for random I/O - read preceeded by a write + test byte ptr ES:[SI+P_FLAGS],READWRITE+WRITE_ONLY + jz take_c00 ;skip if input port + mov BL,byte ptr ES:[SI+P_FLAGS] ;get port flags + and BL,DIRTY+STRIO+OPEN+WINDOW ;isolate appropriate flags + cmp BL,DIRTY+OPEN ;buffer modified? + jne take_c00 ; no, jump + and byte ptr ES:[SI+P_FLAGS],NOT DIRTY ;clear flag + +; this read was preceded by at least one write, so reposition file pointer +; so it rereads the buffer + mov BX,word ptr ES:[SI+HANDLE] + dec word ptr ES:[SI+CHUNK] + mov CX,word ptr ES:[SI+CHUNK] + xor DL,DL + mov DH,CL + mov CL,CH + xor CH,CH + mov AX,4200h ; reposition file pointer + int MSDOS + mov BX,ES:[SI+BUF_POS] ; after re-reading file, restore + mov [BP].new_bpos,BX ; current buffer position + jmp take_fil ; go re-read the file + +take_c00: mov BX,word ptr ES:[SI+BUF_POS] + cmp BX,word ptr ES:[SI+BUF_END] + jge take_c01 + jmp take_nxt ; get the next character from buffer +; buffer empty -- fill it up +take_c01: + cmp win_p,0 ; window object? + jne take_c02 + jmp take_fil ; no, jump +take_c02: cmp str_p,0 ; read from string? + je take_win ; no, jump +; read character from string + lea BX,[BP].leng + push BX + lea BX,row ; buffer for characters + push BX + lea SI,port_r + pushm <[SI].C_disp,[SI].C_page> ; port object + mov AX,DS + mov ES,AX ; ES segment points to DS + call stringrd + mov SP,BP + test AX,AX ; check return status + jnz take_ser ; error, jump + lea SI,port_r + mov BX,[SI].C_page + LoadPage ES,BX +;;; LoadPage ES,port_seg ; restore port page +;;; mov ES,port_seg ; reset ES segment + mov SI,port_d ; restore SI register + jmp take_10 +take_ser: lea BX,rd_st_er ; address of error message + push BX + C_call printf ; display error message + mov SP,BP + jmp take_10 +; read from window +take_win: call read_win + mov BX,AX + jmp short take_11 +; +take_10: mov BX,[BP].leng +take_11: mov ES:[SI+BUF_END],BX ; save buffer length + test BX,BX ; length zero? + jnz take_20 ; no, jump + mov ES:[SI+BUF_POS],BX + jmp take_30 +take_20: cmp win_p,0 ; window object? + je take_22 ; no, copy string + cmp str_p,0 ; string? + je take_25 ; no, jump +; copy characters from buffer to file object +take_22: push SI ; save SI register + mov DI,SI + add DI,BUFR + lea SI,row + mov CX,BX ; length of characters to move + cld ; direction forward + rep movsb + pop SI ; restore SI register +take_25: mov BX,[BP].new_bpos ; BX = buffer position +; Return the next character from the input buffer +take_nxt: xor AH,AH + mov AL,byte ptr ES:[SI+BUFR+BX] + inc BX + mov word ptr ES:[SI+BUF_POS],BX + cmp AL,CTRL_Z ; test for control-Z + jne take_ret ; no, return + test direct,BINARY + jnz take_ret ; no, return +take_30: mov AX,256 ; text file, send EOF +take_ret: add SP,offset take_BP ; release local storage + pop BP + pop ES + ret + +; Read from file + public take_fil +take_fil: + cmp word ptr ES:[SI+CHUNK],1 ; operating on first chunk? + jne take_f05 ; no, jump + cmp word ptr ES:[SI+BUF_POS],0 ; Have we filled the buffer yet? + je take_f10 ; yes, jump +take_f05: + inc word ptr ES:[SI+CHUNK] ; bump the chunk number +take_f10: + mov BX,handlee ; file handle + lea CX,[BP].leng ; address of length of bytes to read + lea AX,row ; input buffer + pushm + call zread + mov SP,BP + test AX,AX ; error status + jz take_50 ; no, jump +; We will not return from call to dos_err + add AX,(IO_ERRORS_START - 1) ; Make Dos I/O error number + mov BX,1 + lea CX,port_r + pushm ; 1 = non-restartable + call dos_err ; invoke scheme error handler +take_50: jmp take_10 ;relative jump not long enough +take_ch endp +;************************************************************************** +; Read a "record" from window +; ES:SI points to the window object +; Return AX = number of characters read +;************************************************************************** +read_arg struc +read_SI dw ? +read_BX dw ? +sav_p dw ? +sav_d dw ? +read_BP dw ? ; caller's BP + dw ? ; caller's return address +read_arg ends + public read_win +read_win proc near + push BP + sub SP,offset read_BP ; allocate for local storage + mov BP,SP + xor BX,BX ; initialization + mov index,BX + mov sh_ptr,BX + mov insert_m,BX + mov BX,word ptr ES:[SI+CUR_LINE] ; get window information + mov curline,BX + mov DX,word ptr ES:[SI+CUR_COL] + mov curcol,DX + mov DX,word ptr ES:[SI+UL_LINE] + mov ulline,DX + mov DX,word ptr ES:[SI+UL_COL] + mov ulcol,DX + mov DX,word ptr ES:[SI+N_LINES] + mov nlines,DX + mov DX,word ptr ES:[SI+N_COLS] + mov ncols,DX + mov DX,word ptr ES:[SI+T_ATTR] + mov t_attrib,DX + call zcuron ; turn on the cursor +read_001: mov BX,curline ; get the current line number + cmp BX,nlines ; check out of lines + jl read_put + pushm + call zscroll ; scroll up one line + mov SP,BP + mov BX,nlines + dec BX ; cur_line = n_lines - 1 + mov curline,BX + mov curcol,0 ; cur_col = 0 +read_put: mov DX,curcol + add DX,ulcol + add BX,ulline + pushm + call zputcur ; show the cursor + mov SP,BP + call getch ; character returned in AL + test AL,AL ; extended character? + jz read_ex + jmp read_100 +;;; Process extended key sequence +read_ex: call getch ; character returned in AL + cmp AL,LEFT_AR ; left arrow key? + jne read_ra + jmp read_bs ; as backspace +; +read_ra: cmp AL,RIGHT_AR ; right arrow key? + jne read_f3 + mov insert_m,0 ; turn off insert mode + mov BX,sh_ptr + cmp BX,sh_len + jl read_030 ; get character from shadow buffer + jmp read_001 +read_030: lea DI,sh_bufer + mov AL,byte ptr [DI+BX] + jmp read_one +; +read_f3: cmp AL,F3 ; F3 key? + jne read_f5 + mov insert_m,0 ; turn off insert mode +read_041: mov CX,index + cmp CX,buf_len ; index < len? + jl read_043 + jmp read_001 ; no room for more chars +read_043: mov BX,sh_ptr + cmp BX,sh_len ; sh_ptr < sh_length? + jl read_045 + jmp read_001 ; buffer empty +read_045: lea DI,sh_bufer + mov AL,byte ptr [DI+BX] + call echo_ch ; AL = character + mov SP,BP + jmp read_041 +; +read_f5: cmp AL,F5 ; F5 key? + jne read_ins + call ega_curs ; turn off the EGA cursor + mov insert_m,0 ; turn off insert mode + cmp index,0 + jne read_051 + jmp read_001 +read_051: call str_str ; copy characters to shadow buffer + mov BX,index + mov sh_len,BX + mov byte ptr [DI+BX],0 ; end of string + dec BX + mov [BP].read_SI,SI ; save SI register + lea DI,row ; address of row vector + lea SI,column ; address of column vector +read_053: cmp BX,0 + jl read_055 + cmp byte ptr [DI+BX],0 + jl read_055 + mov [BP].read_BX,BX ; save BX + mov CX,BLANK + pushm + xor CH,CH + mov CL,byte ptr [SI+BX] + mov curcol,CX + add CX,ulcol ; ul_col + cur_col + push CX + mov CL,byte ptr [DI+BX] + mov curline,CX + add CX,ulline ; ul_line + cur_line + push CX + call zputc + mov SP,BP + mov BX,[BP].read_BX ; restore BX + dec BX + jmp read_053 +read_055: mov SI,[BP].read_SI ; restore SI register + mov index,0 + mov sh_ptr,0 + jmp read_001 +; +read_ins: cmp AL,INSERT ; insert key? + jne read_del + call ega_curs ; turn off the EGA cursor + mov insert_m,1 ; turn on insert mode + jmp read_001 +; +read_del: cmp AL,DELETE ; delete key? + jne read_EN + mov insert_m,0 ; turn off insert mode + mov BX,sh_ptr + cmp BX,sh_len ; sh_ptr < sh_len? + jl read_d01 + jmp read_001 +read_d01: inc sh_ptr ; sh_ptr++ + jmp read_001 +; +read_EN: cmp AL,ENTER ; enter key? + je read_RT ; as carriage return + jmp read_001 +;;; Process ascii character +read_100: cmp AL,BACKSP ; backspace? + jne read_200 +read_bs: mov insert_m,0 ; turn off insert mode + call ega_curs ; turn off the EGA cursor + mov BX,index + cmp BX,0 + jle read_150 + lea DI,row + dec BX + cmp byte ptr [DI+BX],0 + jl read_150 + mov index,BX + cmp sh_ptr,0 + je read_120 + dec sh_ptr ; decrement sh_ptr pointer +read_120: lea DI,column + xor CH,CH + mov CL,byte ptr [DI+BX] ; update cur_line and cur_col + mov curcol,CX + lea DI,row + xor DH,DH + mov DL,byte ptr [DI+BX] + mov curline,DX + mov BX,BLANK + add CX,ulcol ; ul_col + cur_col + add DX,ulline ; ul_line + cur_line + pushm + call zputc + mov SP,BP + jmp read_001 +read_150: call zbell + jmp read_001 +; +read_200: cmp AL,RETURN ; carriage return? + je read_RT + jmp read_300 ; no, jump +;;; Process return key +read_RT: cmp vid_mode,14 + jl read_rt1 + call ega_curs ; turn off the ega cursor + or cur_off,1 + +read_rt1: mov BX,index + mov byte ptr ES:[SI+BUFR+BX],RETURN ; insert carriage return + inc BX + mov byte ptr ES:[SI+BUFR+BX],LF ; insert line feed + inc BX + mov index,BX + mov DX,curline + mov curcol,0 ; cur_col = 0 + inc DX ; cur_line++ + cmp DX,nlines ; out of lines? + jl read_220 + pushm + call zscroll ; scroll up one line + mov SP,BP + mov DX,nlines ; yes, cur_line = n_lines - 1 + dec DX +read_220: mov curline,DX ; restore cur_line + call str_str ; copy string into buffer + cmp TRNS_pag,0 ; check transcript file + je read_250 + mov BX,direct + and BX,TRANSCRI + jz read_250 +; transcript file "on" + lea BX,port_r + mov DX,[BX].C_page + mov [BP].sav_p,DX + mov DX,[BX].C_disp + mov [BP].sav_d,DX + pushm + call ssetadr ; set transcript file address + mov SP,BP + mov AX,index + dec AX + push AX + lea BX,sh_bufer + push BX + mov [BP].read_SI,SI ; save SI register + call printstr ; output to transcript file + mov SP,BP + mov SI,[BP].read_SI ; restore SI register + pushm <[BP].sav_d, [BP].sav_p> + call ssetadr ; set current port address + mov SP,BP + lea DI,sh_bufer +read_250: mov BX,index + dec BX + mov byte ptr [DI+BX],0 ; end of string + dec BX + mov sh_len,BX + jmp read_off +; +read_300: cmp AL,LF ; line feed? + jne read_one + jmp read_001 ; ignore line feed key +; +read_one: mov BX,index ; default + cmp BX,buf_len ; index >= len? + jl read_420 + call zbell + jmp read_001 +read_420: call echo_ch ; AL = character + jmp read_001 +; +read_off: call zcuroff ; turn off the cursor + mov BX,curline + mov CX,curcol + mov ES:[SI+CUR_LINE],BX ; save cur_line and cur_col + mov ES:[SI+CUR_COL],CX + mov AX,index ; return length +; +read_ret: add SP,offset read_BP + pop BP + ret +read_win endp + +;***************************************************************************** +; Move the string in port object to buffer sh_bufer +;***************************************************************************** +str_str proc near + lea DI,sh_bufer ; address of shadow buffer +; xor BX,BX +; Clear the buffer +;str_01: cmp BX,sh_len +; jge str_10 +; mov byte ptr [DI+BX],0 +; inc BX +; jmp str_01 +; Move the characters +str_10: push SI ; save SI + add SI,BUFR ; address of input buffer + mov CX,index + mov AX,ES + mov BX,DS + mov ES,BX ; ES:DI points to destination string + mov DS,AX ; DS:SI points to source string +rep movsb + mov ES,AX ; reset segment registers + mov DS,BX + pop SI ; restore SI + lea DI,sh_bufer + ret +str_str endp +;***************************************************************************** +; Echo single character +;***************************************************************************** +echo_ch proc near + push BP + mov BP,SP + + mov BX,word ptr ES:[SI+T_ATTR] ; get attribute + mov t_attrib,BX + + mov BX,index + mov byte ptr ES:[SI+BX+BUFR],AL ; store character + inc BX ; index++ + mov index,BX ; + cmp insert_m,0 ; insert mode? + jne echo_10 + inc sh_ptr ; sh_ptr++ +echo_10: mov DX,curcol + mov CX,curline + cmp DX,ncols ; end of line? + jl echo_20 + inc CX ; yes, cur_line++ + xor DX,DX ; cur_col = 0 +echo_20: lea DI,row + cmp CX,nlines ; out of lines? + jl echo_50 + pushm + call zscroll ; scroll up one line + mov SP,BP + mov CX,nlines + dec CX ; cur_line = n_lines - 1 + xor DX,DX ; cur_col = 0 +; Decrement the contents of row vector + push AX ; save the character + push BX ; save the index + push CX + mov AX,BX ; AX = index + xor BX,BX +echo_30: cmp BX,AX ; j < index? + jge echo_40 +; mov CL,byte ptr [DI+BX] + dec byte ptr [DI+BX] ; row[j]-- +; mov byte ptr [DI+BX],CL + inc BX ; j++ + jmp echo_30 +echo_40: pop CX + pop BX ; restore information + pop AX +echo_50: dec BX ; update row and column vectors + mov byte ptr [DI+BX],CL + lea DI,column + mov byte ptr [DI+BX],DL + cmp AL,TAB ; tab key? + jne echo_100 +; Process the TAB key + mov AX,DX + mov BX,8 + div BL ; AH = cur_col % 8 + sub BL,AH + add DX,BX + cmp DX,ncols ; end of line? + jle echo_60 + mov DX,ncols +echo_60: mov BX,DX + add BX,ulcol + cmp BX,80 ; out of screen? + jl echo_200 + mov BX,79 + pushm + call zputcur + mov SP,BP + jmp echo_200 +; Process the non-TAB key +echo_100: mov curline,CX ; save the information + mov curcol,DX + add DX,ulcol + add CX,ulline + pushm + call zputc + mov SP,BP + mov DX,curcol ; restore the information + mov CX,curline + inc DX +echo_200: mov curline,CX + mov curcol,DX + pop BP + ret +echo_ch endp +;************************************************************************* +; Push a single character back into the input buffer +;************************************************************************* + public pushchar +pushchar proc near + push ES + push BP + mov BP,SP + push SI + push BX +;;; LoadPage ES,port_seg ; Get port page + lea SI,port_r + mov BX,[SI].C_page + LoadPage ES,BX +;;; mov ES,port_seg ; get address of page + mov SI,port_d + mov BX,word ptr ES:[SI+BUF_POS] ; input buffer starting position + cmp BX,0 ; any character available? + jle push_err ; no, error + dec BX + mov word ptr ES:[SI+BUF_POS],BX ; decrement the starting position +push_ret: pop BX + pop SI + pop BP + pop ES + ret +push_err: lea BX,push_er + push BX + C_call printf,,Load_ES ; print error message + mov SP,BP + C_call force_de,,Load_ES ; force_debug() + mov SP,BP + jmp push_ret +pushchar endp + +rd_proc proc near +;************************************************************************* +; Support for read-char-ready? +;************************************************************************* + extrn next_SP:near + extrn src_err:near + public rd_ch_rd + public read_cha + +rd_ch_rd: lods byte ptr ES:[SI] + save + add AX,offset reg0 ; compute register address + mov DI,AX + save ; save DI register + xor CX,CX + push CX + push AX + C_call get_port,,Load_ES ; get port object + mov SP,BP + test AX,AX ; check return status + jz rd_010 + jmp rd_err +; +rd_010: restore + mov [DI].C_page,SPECCHAR*2 ; prepare to return a character + mov SI,tmp_disp + mov BX,tmp_page + LoadPage ES,BX ; get page address +;;; mov ES,word ptr pagetabl+[BX] ; get address of page + mov BX,word ptr ES:[SI+BUF_POS] ; input buffer starting position + cmp BX,word ptr ES:[SI+BUF_END] ; compare with ending position + jge rd_020 + xor AH,AH + mov AL,byte ptr ES:[SI+BUFR+BX] ; get the character +rd_T: cmp AL,CTRL_Z ; control-Z? + jne rd_015 + mov BX,word ptr ES:[SI+P_FLAGS] + and BX,BINARY ; binary file? + jnz rd_015 +rd_eof: mov [DI].C_page,EOF_PAGE*2 ; return eof character + mov [DI].C_disp,EOF_DISP + jmp next_SP +; +rd_015: mov [DI].C_disp,AX ; return the character + jmp next_SP +; no character in input buffer +rd_020: mov AX,word ptr ES:[SI+P_FLAGS] + mov BX,AX + and AX,WINDOW ; window? + jz rd_030 + call zch_rdy ; any character? + test AX,AX + jz rd_no + xor AH,AH ; yes + jmp rd_T +; no character available -- return '() +rd_no: xor AX,AX + mov [DI].C_page,AX + mov [DI].C_disp,AX + jmp next_SP +; not a window +rd_030: and BX,OPEN ; open? + jz rd_no ; no, return '() + pushm + call ssetadr + mov SP,BP + call take_ch ; get one character + mov SP,BP + restore + cmp AX,256 ; eof? + je rd_eof + call pushchar ; no, put it back + mov SP,BP + jmp rd_015 + +; Wrong port object, display error message +rd_err: lea BX,ch_rd + jmp src_err ; link to error handler + +;;;************************************************************************ +;;; Support for read-char +;;;************************************************************************ +read_cha: lods byte ptr ES:[SI] + save + add AX,offset reg0 ; compute register address + mov DI,AX + save ; save DI register + xor CX,CX + push CX + push AX + C_call get_port,,Load_ES ; get port object + mov SP,BP + test AX,AX ; check return status + jz rc_010 + jmp rc_err +; +rc_010: restore + mov [DI].C_page,SPECCHAR*2 + mov BX,tmp_page + LoadPage ES,BX ; get page address +;;; mov ES,word ptr pagetabl+[BX] ; get address of page + mov SI,tmp_disp + mov AX,word ptr ES:[SI+P_FLAGS] ; get port flags + mov BX,AX + and AX,WINDOW ; window object? + jz rc_050 + and BX,STRIO ; string object? + jnz rc_050 + mov CX,word ptr ES:[SI+BUF_POS] + cmp CX,word ptr ES:[SI+BUF_END] ; any character in buffer? + jl rc_050 + mov CX,word ptr ES:[SI+CUR_LINE] + add CX,word ptr ES:[SI+UL_LINE] + mov DX,word ptr ES:[SI+CUR_COL] + add DX,word ptr ES:[SI+UL_COL] + + push AX + mov AX,word ptr ES:[SI+T_ATTR] + mov t_attrib,AX + pop AX + + pushm + call zputcur ; cursor position + mov SP,BP + call zcuron ; cursor on + mov SP,BP + call getch ; get character + mov [DI].C_disp,AX + mov byte ptr ES:[SI+BUFR],AL ; store in port object + call zcuroff ; cursor off + mov SP,BP + mov BX,1 + mov word ptr ES:[SI+BUF_POS],BX + mov word ptr ES:[SI+BUF_END],BX + jmp next_SP +; +rc_050: pushm + call ssetadr ; set port address + mov SP,BP + call take_ch ; take one character + mov SP,BP + restore + cmp AX,256 ; eof? + je rc_060 + jmp rd_015 ; return the character +rc_060: jmp rd_eof +; +rc_err: lea BX,rch_er ; address of error message + jmp src_err ; jump to error handler +rd_proc endp +;;;**************************************************************** +;;; Output a single character +;;;**************************************************************** +give_arg struc +lenn dw ? ; character string length +lenn2 dw ? ; second copy of length +sav_pg dw ? +sav_ds dw ? +give_SI dw ? +give_DX dw ? +give_CX dw ? +give_BX dw ? +give_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +char dw ? ; the character to be output +give_arg ends + extrn zscroll:near + extrn force_de:near + extrn zputc:near + extrn printf:near + extrn zwrite:near + extrn force_re:near + public givechar +givechar proc near + push ES + push BP + sub SP,offset give_BP + mov BP,SP + mov [BP].give_SI,SI ; save registers + mov [BP].give_DX,DX + mov [BP].give_CX,CX + mov [BP].give_BX,BX + cmp TRNS_pag,0 ; transcript file? + je give_010 + mov BX,direct + and BX,TRANSCRI + jz give_010 +; transcript file "on" + lea BX,port_r + mov DX,[BX].C_page + mov [BP].sav_pg,DX + mov DX,[BX].C_disp + mov [BP].sav_ds,DX + pushm + call ssetadr ; set transcript file + mov SP,BP + push [BP].char + call givechar ; output to transcript file + mov SP,BP + pushm <[BP].sav_ds,[BP].sav_pg> + call ssetadr ; set port address + mov SP,BP +; +give_010: mov CX,[BP].char + cmp win_p,0 ; window? + jne give_015 + jmp give_fil ; no, jump +give_015: cmp str_p,0 ; string? + je give_018 + jmp give_030 ; yes, return +; Output to window +give_018: cmp CL,RETURN ; carriage return? + jne give_020 + mov CL,LF ; yes, change to LF +give_020: +;;; call putc_win ; putc_window +;;;******************************************************************** +;;; Output Character to Window +;;; +;;; Description:This routine writes a character to the current cursor +;;; position, then increments the cursor location. +;;; If the current cursor position is now within the bounds +;;; of the window, the character is output in the first +;;; column of the next line, scrolling the window, if +;;; necessary. The current text attributes are used to +;;; write the character. +;;; Note: CX = character +;;;******************************************************************** + mov SI,port_d ; get displacement + lea BX,port_r + mov BX,[BX].C_page + LoadPage ES,BX +;;; LoadPage ES,port_seg ; get port page +;;; mov ES,port_seg ; get page segment + mov AX,direct ; get the port flag + and AX,OPEN ; open for write? + jnz putc_002 + jmp give_ret +putc_002: mov BX,word ptr ES:[SI+CUR_LINE] ; BX = cur_line + mov AX,word ptr ES:[SI+CUR_COL] ; AX = cur_col + mov DX,word ptr ES:[SI+UL_LINE] + mov ulline,DX + mov DX,word ptr ES:[SI+UL_COL] + mov ulcol,DX + mov DX,word ptr ES:[SI+N_LINES] + mov nlines,DX + mov DX,word ptr ES:[SI+N_COLS] + mov ncols,DX + mov DX,word ptr ES:[SI+T_ATTR] + mov t_attrib,DX +; Check for the character + cmp CL,NULL_CH ; null character? + jne putc_010 + jmp give_ret ; do nothing +; +putc_010: cmp CL,BACKSP ; backspace? + jne putc_020 + dec AX + cmp AX,0 + jl putc_015 + jmp putc_120 +putc_015: xor AX,AX ; cur_col = 0 + jmp putc_120 +; +putc_020: cmp CL,BELL_CH ; bell character? + jne putc_030 + call zbell ; sound the alarm + mov SP,BP + jmp give_ret +; +putc_030: cmp CL,TAB ; tab character? + jne putc_050 + mov CX,AX + mov DX,8 ; DL = 8 + div DL ; AH = (cur_col % 8) + sub DL,AH + add CX,DX + mov AX,CX + jmp putc_120 +; +;putc_040: cmp CL,RETURN ; carriage return? +; jne putc_050 +; xor AX,AX ; cur_col = 0 +; jmp putc_100 +; +putc_050: cmp CL,LF ; line feed? + jne putc_060 + xor AX,AX + inc BX + cmp BX,nlines ; out of lines? + jge putc_055 + jmp putc_100 +putc_055: pushm + call zscroll ; scroll window up one line + mov SP,BP + mov BX,nlines + dec BX + xor AX,AX + jmp putc_100 +; default +putc_060: cmp AX,ncols ; check end of line + jl putc_080 + mov DX,word ptr ES:[SI+W_FLAGS] + and DX,WRAP + jz putc_070 + inc BX ; wrap + xor AX,AX + jmp putc_080 +putc_070: inc AX ; clip + jmp putc_100 ; no display +putc_080: cmp BX,nlines ; check out of lines? + jl putc_090 + pushm + call zscroll ; scroll window up one line + mov SP,BP + mov BX,nlines + dec BX ; set up current line number + xor AX,AX ; and current column number +putc_090: mov curcol,AX + mov curline,BX + push t_attrib ; text character attribute + push [BP].char ; character + add AX,ulcol + push AX ; column number to console + add BX,ulline + push BX ; line number to console + call zputc ; write on cursor position + mov SP,BP + mov AX,curcol + mov BX,curline + inc AX ; increment current column +putc_100: mov ES:[SI+CUR_LINE],BX ; save current cursor line number +putc_120: mov ES:[SI+CUR_COL],AX ; save current cursor column number +give_030: jmp give_ret +; Output to file +give_fil: lea BX,[BP].lenn + mov word ptr [BX],1 ; lenn <- 1 + mov word ptr [BX+2],1 ; lenn2 <- 1 + lea SI,[BP].char + mov AX,handlee + test direct,BINARY ; Binary file? + jnz give_50 ; Yes, jump + cmp CL,LF ; Line feed? + jne give_50 ; no, jump + mov word ptr [SI],RETURN ; output carriage return + pushm + call zwrite + mov SP,BP + test AX,AX ; check return status + jnz give_er ; error, jump + mov AX,[BP].lenn ; #chars spec'd = #chars written? + cmp AX,[BP].lenn2 + jne give_disk + mov AX,handlee + jmp give_80 +; +give_50: pushm + call zwrite + mov SP,BP + test AX,AX + jnz give_er + mov AX,[BP].lenn ; #chars spec'd = #chars written? + cmp AX,[BP].lenn2 + cmp AX,[BP].lenn2 + jne give_disk + test direct,BINARY ; Binary file? + jnz give_100 ; yes, jump + cmp word ptr [SI],RETURN ; carriage return? + jne give_100 ; no, jump + mov AX,handlee +;;; cmp AX,prn_hand ; printer? +;;; je give_100 ; yes, jump +give_80: lea SI,[BP].char + mov word ptr [SI],LF ; output line feed + lea BX,[BP].lenn + mov word ptr [BX],1 + pushm + call zwrite + mov SP,BP + test AX,AX ; check return status + jnz give_er + mov AX,[BP].lenn ; #chars spec'd = #chars written? + cmp AX,[BP].lenn2 + cmp AX,[BP].lenn2 + je give_100 +give_disk: + mov ax,DISK_FULL_ERROR ; Note disk full error + jmp short give_er1 +give_er: add ax,(IO_ERRORS_START - 1) ; make dos i/o error number +give_er1: mov BX,1 + lea CX,port_r + pushm ; 1 = non-restartable + ; We will not return from call to dos_err + call dos_err ; invoke scheme error handler + +give_100: lea BX,port_r + mov BX,[BX].C_page + LoadPage ES,BX +;;; LoadPage ES,port_seg +;;; mov ES,port_seg + mov BX,word ptr [SI] ; get the character + mov SI,port_d + mov AX,word ptr ES:[SI+CUR_COL] + test direct,BINARY ; Binary file? + jnz give_200 + cmp BL,BACKSP ; back space? + jne give_110 + dec AX + cmp AX,0 + jge give_200 +give_rt: xor AX,AX + jmp give_200 +give_110: cmp BL,TAB ; tab? + jne give_120 + mov CX,AX + mov DX,8 + div DL ; AH = (cur_col % 8) + sub DL,AH + add CX,DX + mov AX,CX + jmp give_200 +; +give_120: cmp BL,RETURN ; carriage return? + jne give_130 ; no, continue + mov BL,LF ; yes, make it a linefeed + jmp give_rt +; +give_130: cmp BL,LF ; line feed? + jne give_140 + jmp give_rt +; default +give_140: cmp AX,word ptr ES:[SI+N_COLS] + jge give_rt + inc AX +; +give_200: + cmp word ptr ES:[SI+N_COLS],0 ; Line length = 0 ? + je give_20a ; Yes, don't maintain column + mov ES:[SI+CUR_COL],AX +give_20a: mov AX,word ptr ES:[SI+BUF_POS] + inc AX + test direct,BINARY ; Binary file? + jnz give_20b ; yes, jump + cmp BX,LF ; CR or LF just output? + jne give_20b ; no, jump + inc AX ; yes bump # bytes written +give_20b: + cmp AX,256 ; Exceed chunk boundary? + jle give_201 ; no, jump + sub AX,256 ; AX = excess above chunk + inc word ptr ES:[SI+CHUNK] ; bump chunk # +give_201: mov word ptr ES:[SI+BUF_POS],AX ; set the buffer position + +give_ret: xor AX,AX + add SP,offset give_BP ; release local storage + mov SI,[BP].give_SI ; restore registers + mov DX,[BP].give_DX + mov CX,[BP].give_CX + mov BX,[BP].give_BX + pop BP + pop ES + ret +givechar endp + +prog ends + end + \ No newline at end of file diff --git a/cprint.asm b/cprint.asm new file mode 100644 index 0000000..ad31db2 --- /dev/null +++ b/cprint.asm @@ -0,0 +1,229 @@ +; =====> CPRINT.ASM +;****************************************** +;* TIPC Scheme Runtime Support * +;* Scheme Interpreter Support for write * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 21 March 1986 * +;* Last Modification: 21 March 1986 * +;****************************************** + page 60,132 + include scheme.equ + include sinterp.arg +LF equ 0Ah +SPACE equ 20h + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + extrn display:word + extrn show:word +;;; extrn detail:word +sp1_er db "WRITE",0 +spc_er db "DISPLAY",0 +spt_er db "PRINT",0 +new_er db "NEWLINE",0 +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP +prn_proc proc near + extrn next_SP:near + extrn src_err:near + extrn get_port:near + extrn sprint:near +;;; +;;; Does not set the value for flag "detail" (which is removed in CPRINT1.ASM) +;;; +;;;**************************************************************************** +;;; Print an S-Expression (w/ slashification) +;;; Purpose: Scheme interpreter support to output an s-expression to +;;; a port. +;;;**************************************************************************** + public spprin1 +spprin1: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 ; write indicator + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz sp1_010 + lea BX,sp1_er + jmp src_err ; link to error handler +sp1_010: +;;; mov detail,AX + inc AX + mov display,AX + mov show,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; write + mov SP,BP +sp1_020: restore ; get the register pointer + mov [DI].C_page,NPR_PAGE*2 ; return as non-printable object + mov [DI].C_disp,NPR_DISP + jmp next_SP ; return to interpreter +;;;**************************************************************************** +;;; Print an S-Expression (w/o slashification) +;;; Purpose: Scheme interpreter support to output an s-expression to +;;; a port. +;;;**************************************************************************** + public spprinc +spprinc: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz spc_010 + lea BX,spc_er + jmp src_err ; link to error handler +spc_010: mov display,AX +;;; mov detail,AX + inc AX + mov show,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; display + mov SP,BP + jmp sp1_020 +;;;**************************************************************************** +;;; Print an S-Expression (w/ spacing control) +;;; Purpose: Scheme interpreter support to output an s-expression to +;;; a port. +;;;**************************************************************************** + public spprint +spprint: lods word ptr ES:[SI] ; load register operand + save + xor BX,BX + mov BL,AH + add BX,offset reg0 ; BX = port object + xor AH,AH + add AX,offset reg0 ; AX = s-expression pointer + mov DI,AX + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz spt_010 + lea BX,spt_er + jmp src_err ; link to error handler +spt_010: mov display,AX +;;; mov detail,AX + inc AX + mov show,AX + mov DX,SPECCHAR + mov BX,LF ; line feed + pushm + call sprint ; print it + mov SP,BP + xor AX,AX +;;; mov detail,AX + inc AX + mov show,AX + mov display,AX + pushm + restore + mov BX,[DI].C_page + shr BX,1 + pushm <[DI].C_disp, BX> + call sprint ; print the s-expression + mov SP,BP + mov BX,SPACE + mov DX,SPECCHAR ; space + xor AX,AX +;;; mov detail,AX + mov display,AX + inc AX + mov show,AX + pushm + call sprint ; print it + mov SP,BP + jmp sp1_020 +;;;**************************************************************************** +;;; Print a "newline" character +;;; Purpose: Scheme interpreter support to output a newline character +;;; to a port. +;;;**************************************************************************** + public spnewlin +spnewlin: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; AX = port object + mov CX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + test AX,AX ; check return status + jz new_010 + lea BX,new_er + jmp src_err ; link to error handler +new_010: mov display,AX +;;; mov detail,AX + inc AX + mov show,AX + mov BX,SPECCHAR + mov DX,LF ; linefeed + pushm + call sprint + mov SP,BP + jmp next_SP ; return to interpreter +;;;**************************************************************************** +;;; Find Print-length of an S-Expression +;;; Purpose: Scheme interpreter support to determine the print length +;;; of a scheme object. +;;;**************************************************************************** + public prt_len +prt_len: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; AX = port object + mov DI,AX + xor CX,CX + mov display,CX ; no display and show + mov show,CX +;;; inc CX +;;; mov detail,CX + save + mov DX,OUT_PAGE*2 + mov CX,OUT_DISP + mov BX,[DI].C_page + shr BX,1 ; correct page number + pushm + call sprint + mov SP,BP ; AX = print length + restore + mov [DI].C_page,SPECFIX*2 + mov [DI].C_disp,AX ; get the print length + jmp next_SP ; return to interpreter +prn_proc endp +prog ends + end + + \ No newline at end of file diff --git a/cprint1.asm b/cprint1.asm new file mode 100644 index 0000000..fc82340 --- /dev/null +++ b/cprint1.asm @@ -0,0 +1,755 @@ +; =====> CPRINT1.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* S-Expression printing * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* Last Modification: 10 Feb 1987 * +;* * +;* tc 2/10/87 fixed problem printing * +;* circular data structs * +;* rb 1/21/88 binary I/O uses * +;* line-length = 0; * +;* set dirty bit on writes * +;* (commented out) * +;* * +;*************************************** + page 60,132 + include scheme.equ + +P_FLAGS equ 6 +TEST_NUM equ 8 +RETURN equ 0Dh +SPACE equ 20h +CUR_COL equ 12 +N_COLS equ 20 +SYM_OVHD equ 7 +HEAPERR equ -3 + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public display, show, detail, ccount + extrn port_seg:word + extrn port_d:word + extrn port_r:word + extrn direct:word + extrn test_ch:word + extrn t_array:word +ab_write db "[WARNING: Output aborted by SHIFT-BREAK]",0 +deep_str db "#",0 +port_str db "#",0 +parens db "()",0 +cont_str db "#",0 +ary_str db "#(" +free_str db "#",0 +code_str db "#",0 +env_str db "#",0 +clos_str db "# + call ssetadr ; set port address + mov SP,BP + +;fix for random i/o - note a write has taken place + lea SI,port_r + mov BX,[SI].C_page + LoadPage ES,BX + mov SI,port_d + or word ptr ES:[SI+P_FLAGS],DIRTY + + pushm <[BP].dis, [BP].pg> + call subsprin ; print it + mov SP,BP + mov AX,ccount ; return number of characters + pop BP + ret +sprint endp +;************************************************************************** + extrn take_cdr:near + extrn restart:near + extrn stkspc:near + extrn get_sym:near + extrn givechar:near + extrn gvchars:near + extrn copybig:near + extrn fix2big:near + extrn big2asc:near + extrn get_flo:near + extrn isspace:near + extrn abort:near + +subp_arg struc +tmp_reg1 dw ? +tmp_reg2 dw ? +tmp_reg3 dw ? +tmp_pg dw ? +tmp_SI dw ? +ch_buf db 14 dup (0) ; character buffer +subp_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +spg dw ? ; page number +sdis dw ? ; displacement +subp_arg ends + +subsprin proc near + push ES + push BP + sub SP,offset subp_BP ; allocate local storage + mov BP,SP + cmp s_break,0 ; check for SHIFT-BREAK + je subp_10 +kill_out: mov AX,RETURN ; carriage return + push AX + call givechar + mov SP,BP + mov AX,41 ; length of message + lea BX,ab_write + pushm + call printstr ; display message + mov SP,BP + cmp show,0 + je kill_01 + xor AX,AX + jmp kill_02 +kill_01: mov AX,2 +kill_02: push AX ; instruction length + C_call restart ; link to scheme debugger + ; control does not return to here +subp_10: call stkspc ; check stack space + cmp AX,64 ; stack low? + jge subp_20 ; no, jump + mov AX,8 + lea BX,deep_str + pushm + call printstr ; print no deeper + mov SP,BP + jmp subp_ret +; act on object type +subp_20: shl [BP].spg,1 ; adjust page number + mov BX,[BP].spg + mov DI,ptype+[BX] ; get port type + jmp branchtab+[DI] + +;; the individual type handlers + +; handle for list +sp_list: test BX,BX ; null page? + jnz sp_l01 ; no, jump + mov AX,2 + lea BX,parens + pushm + call printstr ; print "()" + mov SP,BP + jmp subp_ret +sp_l01: mov DX,28h ; '(' + push DX + call printcha + mov SP,BP + mov BX,[BP].spg ; Get page + LoadPage ES,BX ; Get paragraph address of page + mov SI,[BP].sdis ; dispacement +sp_l02: mov [BP].tmp_pg,BX ; Save page + mov [BP].tmp_SI,SI ; and displacement + xor DH,DH + mov DL,byte ptr ES:[SI] ; Get car's page + shr DX,1 ; Change to number for subsprin + mov CX,word ptr ES:[SI+1] ; Get car's displacement + pushm + call subsprin ; Go print it + mov SP,BP + mov BX,[BP].tmp_pg ; Restore page + LoadPage ES,BX ; Its para address + mov SI,[BP].tmp_SI ; and displacement + mov BL,byte ptr ES:[SI+3] ; Get cdr's page offset + mov SI,word ptr ES:[SI+4] ; and displacement + test BX,BX ; more items in list? + jz sp_l04 ; no, jump + mov [BP].tmp_SI,SI ; save registers + mov [BP].tmp_reg1,BX + mov DX,SPACE ; print ' ' + push DX + call printcha + mov SP,BP + mov BX,[BP].tmp_reg1 ; restore registers + mov SI,[BP].tmp_SI + LoadPage ES,BX ; Get paragraph address of page + cmp byte ptr ptype+[BX],LISTTYPE*2 ; check port type + je sp_l02 +; last cdr not nil + mov [BP].tmp_SI,SI ; save registers + mov [BP].tmp_reg1,BX + mov DX,2Eh ; print '.' + push DX + call printcha + mov SP,BP + mov DX,SPACE ; print ' ' + push DX + call printcha + mov SP,BP + mov BX,[BP].tmp_reg1 ; restore registers + mov SI,[BP].tmp_SI + shr BX,1 ; corrected page number + pushm + call subsprin + mov SP,BP +sp_l04: mov DX,29h ; print ')' + push DX + call printcha + mov SP,BP + jmp subp_ret +; handle for fixnum +sp_fix: mov AX,5 + mov [BP].tmp_reg2,AX + push AX + C_call getmem + mov SP,BP + cmp AX,0 + je mem_err + mov [BP].tmp_reg1,AX ; address of divider + mov SI,[BP].sdis ; get the value + shl SI,1 + sar SI,1 + pushm + mov AX,DS + mov ES,AX ; get the right ES segment + call fix2big ; change to bignum + mov SP,BP + jmp printint +mem_err: mov AX,HEAPERR ; memory not available + push AX + call abort + mov SP,BP + jmp subp_ret ; return +; handle for flonum +sp_flo: mov SI,[BP].sdis ; displacement + shr BX,1 ; corrected page number + pushm + call get_flo ; get a floating point value + pushm ; in AX:BX:CX:DX + C_call printflo,,Load_ES + mov SP,BP + jmp subp_ret +; handle for array +sp_ary: mov AX,2 + LoadPage ES,BX ; page segment + lea BX,ary_str ; print "#(" + pushm + call printstr + mov SP,BP + + LoadPage ES,[BP].spg ; Get page address of array +;;; mov ES,word ptr pagetabl+[BX] + mov SI,[BP].sdis ; and segment + mov CX,word ptr ES:[SI+1] + sub CX,BLK_OVHD ; length of array + mov BX,BLK_OVHD + mov [BP].tmp_reg1,CX +sp_a01: + cmp BX,[BP].tmp_reg1 + jle sp_a04 + jmp sp_l04 +sp_a04: mov AL,byte ptr ES:[SI+BX] ; AX <= page of array element + mov DX,word ptr ES:[SI+BX+1] ; DX <= disp. of array element + xor AH,AH + shr AX,1 ; Page number for subsprin + mov [BP].tmp_reg2,BX ; Save registers + mov [BP].tmp_SI,SI + pushm + call subsprin ; print element + mov SP,BP + mov BX,[BP].tmp_reg2 ; restore BX + cmp BX,[BP].tmp_reg1 ; last element? + jge sp_a02 + mov DX,SPACE ; print ' ' + push DX + call printcha + mov SP,BP + mov BX,[BP].tmp_reg2 ; restore registers +sp_a02: mov SI,[BP].tmp_SI + add BX,PTRSIZE + LoadPage ES,[BP].spg ; Reload page address of array + jmp sp_a01 +; handle for continuation +sp_cont: mov AX,15 + lea BX,cont_str + pushm + call printstr + mov SP,BP + jmp subp_ret +; handle for closure +sp_clos: mov AX,11 + lea BX,clos_str + pushm + call printstr ; print "# ; [tmp_reg1] = disp + call get_sym ; get the symbol name + mov SP,BP + mov DX,SPACE + push DX + call printcha ; print ' ' + mov SP,BP + pushm <[BP].tmp_reg3, [BP].tmp_reg2> + call printstr ; print the symbol name + mov SP,BP + mov BX,[BP].tmp_reg3 + inc BX + pushm + C_call rlsmem + mov SP,BP +sp_c04: mov DX,3Eh + push DX + call printcha ; print '>' + mov SP,BP + jmp subp_ret +; handle for free +sp_free: mov AX,7 + lea BX,free_str + pushm + call printstr ; print # + mov SP,BP + jmp subp_ret +; handle for code block +sp_code: mov AX,7 + lea BX,code_str + pushm + call printstr ; print # + mov SP,BP + jmp subp_ret +; handle for environment +sp_env: mov AX,14 + lea BX,env_str + pushm + call printstr ; print # + mov SP,BP + jmp subp_ret +; handle for symbol +sp_sym: mov AX,7Ch + mov CX,SYM_OVHD + mov SI,[BP].sdis + shr BX,1 ; corrected page number + pushm + C_call printatm,,Load_ES ; print the symbol + mov SP,BP + jmp subp_ret +; handle for string +sp_str: LoadPage ES,BX ; Get address of page + mov SI,[BP].sdis ; and displacement + mov CX,word ptr ES:[SI+1] + cmp CX,0 ; check for small string + jge sp_s01 + add CX,BLK_OVHD+PTRSIZE +sp_s01: sub CX,BLK_OVHD ; get the string length + mov [BP].tmp_reg1,CX ; save the string length + mov DX,ccount + add DX,CX + mov ccount,DX + cmp show,0 + jne sp_s02 + jmp subp_ret +sp_s02: add SI,BLK_OVHD ; advance pointer to string + mov [BP].tmp_SI,SI + cmp display,0 + jne sp_s02a + jmp sp_sdis +; write, need to print double quotes, escape characters +sp_s02a: xor BX,BX + mov DX,2 ; strange = 2 +sp_s001: cmp BX,CX + jge sp_s05 + mov AL,byte ptr ES:[SI+BX] + cmp AL,5Ch ; check for \ + je sp_s03 + cmp AL,22h ; check for " + jne sp_s04 +sp_s03: inc DX +sp_s04: inc BX + jmp sp_s001 +sp_s05: add DX,CX ; strange + len + push DX + call wrap + mov AX,22h + push AX + call givechar ; print " for string + mov SP,BP + xor BX,BX + mov SI,[BP].tmp_SI +sp_s06: cmp BX,[BP].tmp_reg1 ; finish the string? + jge sp_s10 + cmp s_break,0 ; check for SHIFT-BREAK + je sp_s07 + jmp kill_out ; yes, jump +sp_s07: + LoadPage ES,[BP].spg ; Ensure string page loaded + mov DL,byte ptr ES:[SI+BX] ; Get one character + xor DH,DH + mov [BP].tmp_reg2,BX ; save registers + cmp DL,5Ch ; \? + je sp_s08 + cmp DL,22h ; "? + jne sp_s09 +sp_s08: mov AX,5Ch + mov [BP].tmp_reg3,DX ; save the character + push AX + call givechar ; print the \ for special + mov SP,BP + mov DX,[BP].tmp_reg3 +sp_s09: push DX + call givechar ; print the character + mov SP,BP + mov SI,[BP].tmp_SI ; restore registers + mov BX,[BP].tmp_reg2 + inc BX + jmp sp_s06 +sp_s10: mov AX,22h + push AX + call givechar ; print " + mov SP,BP + jmp subp_ret +; display, just print the string +sp_sdis: push CX + call wrap + xor BX,BX + mov SI,[BP].tmp_SI +sp_s11: cmp BX,[BP].tmp_reg1 ; finish the string? + jl sp_s12 + jmp subp_ret ; yes, return +sp_s12: cmp s_break,0 ; check for SHIFT-BREAK + je sp_s13 + jmp kill_out ; yes, jump +sp_s13: xor AH,AH + LoadPage ES,[BP].spg ; Ensure string page loaded + mov AL,byte ptr ES:[SI+BX] ; get the character + push AX + mov [BP].tmp_reg2,BX ; save registers + call givechar ; print the character + mov SP,BP + mov BX,[BP].tmp_reg2 ; restore registers + mov SI,[BP].tmp_SI + inc BX ; increment the index + jmp sp_s11 +; handle for character +sp_char: mov SI,[BP].sdis + and SI,00FFh ; get the low byte for character + cmp display,0 + je sp_c10 + mov AX,SI ; AL = character + lea SI,[BP].ch_buf + mov byte ptr [SI],23h ; # + mov byte ptr [SI+1],5Ch ; \ + mov byte ptr [SI+2],AL ; character + mov byte ptr [SI+3],0 ; end of string +; check for a special multi-character character constant + xor BX,BX + lea DI,test_ch +sp_ch01: cmp BX,TEST_NUM ; end of comparison? + jl sp_ch02 + mov BX,3 ; yes + jmp sp_ch12 +sp_ch02: cmp AL,byte ptr [DI+BX] ; compare with special char + je sp_ch05 + inc BX + jmp sp_ch01 +sp_ch05: lea DI,t_array + shl BX,1 ; get the word offset + mov DI,word ptr [DI+BX] ; pointer to special char string + mov BX,2 +sp_ch03: cmp byte ptr [DI],0 ; end of string? + je sp_ch04 ; yes, jump + mov AL,byte ptr [DI] + mov byte ptr [SI+BX],AL ; move character by character + inc BX + inc DI + jmp sp_ch03 +sp_ch04: mov byte ptr [SI+BX],0 ; end of string +sp_ch12: pushm ; BX = length of buffer + call printstr + mov SP,BP + jmp subp_ret +; print character without escapes +sp_c10: push SI + call printcha + mov SP,BP + jmp subp_ret +; handle for bignum +sp_big: LoadPage ES,BX + mov SI,[BP].sdis + mov AX,word ptr ES:[SI+1] ; get object size + dec AX + mov [BP].tmp_reg2,AX + push AX + C_call getmem ; allocate memory for divider + mov SP,BP + cmp AX,0 ; memory available? + jne sp_big1 + jmp mem_err ; no, error +sp_big1: mov [BP].tmp_reg1,AX ; address of divider + mov BX,[BP].spg + shr BX,1 + pushm + mov AX,DS + mov ES,AX ; get the right ES segment + call copybig ; copy bignum to buffer +printint: + mov AX,[BP].tmp_reg2 + mov BX,3 + mul BX + sub AX,5 + mov [BP].tmp_SI,AX + push AX + C_call getmem ; allocate memory for char buffer + mov SP,BP + cmp AX,0 ; memory available? + jne sp_big2 + jmp mem_err ; no, error +sp_big2: mov [BP].tmp_reg3,AX ; address of bigchars + pushm + call big2asc ; convert bignum to char string + mov SP,BP ; AX = characters count + pushm + call printstr ; print the bignum + mov SP,BP + pushm <[BP].tmp_reg2, [BP].tmp_reg1> + C_call rlsmem + pushm <[BP].tmp_SI, [BP].tmp_reg3> + C_call rlsmem + mov SP,BP + jmp subp_ret +; handle for port +sp_port: mov AX,7 + lea BX,port_str + pushm + call printstr ; print # + mov SP,BP +sp_ref: +subp_ret: add SP,offset subp_BP ; release local storage + pop BP + pop ES + ret +subsprin endp +;****************************************************************************** +; Print a single character to the file, and send a newline +; if necessary. +;****************************************************************************** +pch_arg struc + dw ? ; caller's BP + dw ? ; caller's return address +cha dw ? ; character +pch_arg ends + +printcha proc near + push BP + mov BP,SP + inc ccount ; ccount++ + cmp show,0 ; show? + je prch_ret ; no, return + call currspc ; check spaces remaining + cmp AX,0 + jle prch_01 +prch_001: push [BP].cha + call givechar + mov SP,BP + jmp prch_ret ; return to caller +prch_01: test direct,BINARY + jnz prch_001 + mov AX,RETURN + push AX + call givechar ; newline + mov SP,BP + push [BP].cha + call isspace ; after newline, print nonspaces + test AX,AX + jnz prch_ret ; space, return + jmp prch_001 +prch_ret: pop BP + ret ; return to caller +printcha endp +;****************************************************************************** +; Print the string with length LEN, first sending a newline +; if necessary. +;****************************************************************************** +str_arg struc + dw ? ; caller's BP + dw ? ; caller's return address +str dw ? ; string pointer +len dw ? ; string length +str_arg ends + public printstr +printstr proc near + push BP + mov BP,SP + push [BP].len + call wrap ; check available spaces + mov AX,ccount + add AX,[BP].len ; ccount += len + mov ccount,AX + cmp show,0 ; show? + je pstr_ret ; no, return + pushm <[BP].len, [BP].str> + call gvchars ; display all characters +pstr_ret: pop BP + ret +printstr endp +;****************************************************************************** +; Return number of spaces remaining on current line +;****************************************************************************** +currspc proc near + pop DI ; get the return address + push ES + push SI + lea SI,port_r + mov SI,[SI].C_page + LoadPage ES,SI +;;; LoadPage ES,port_seg ; Get port para address + mov SI,port_d + mov AX,word ptr ES:[SI+N_COLS] ; line length + test AX,AX ; line length defined? + jnz curr_01 + mov AX,-1 ; no, return negative value + jmp curr_02 +curr_01: sub AX,word ptr ES:[SI+CUR_COL] +curr_02: pop SI + pop ES + jmp DI ; return to caller +currspc endp +;****************************************************************************** +; Return current column +;****************************************************************************** +curr_col proc near + pop DI ; get the return address + push ES + push SI + lea SI,port_r + mov SI,[SI].C_page + LoadPage ES,SI +;;; LoadPage ES,port_seg ; Get port para address + mov SI,port_d + mov AX,word ptr ES:[SI+N_COLS] ; Get Number of columns + or AX,AX ; Maintaining column? + jz ccol_ret ; No, just return 0 + mov AX,word ptr ES:[SI+CUR_COL] ; Yes, get column and return +ccol_ret: pop SI + pop ES + jmp DI ; return to caller +curr_col endp +;****************************************************************************** +; Wrap issues a newline if there are less than LEN spaces +; left on the current output line. +; Note: DX = LEN +;****************************************************************************** + public wrap +wrap proc near + pop DI ; get the return address + pop DX ; get the length + cmp show,0 + jz wrap_ret + push DI ; save return address + call curr_col ; get the current column number + pop DI ; restore return address + cmp AX,1 + jle wrap_ret + push DI ; save return address + call currspc ; get the available spaces + pop DI ; restore return address + cmp AX,DX + jge wrap_ret + mov AX,RETURN ; issue a newline + push AX + call givechar + mov SP,BP +wrap_ret: jmp DI ; return to caller +wrap endp + +prog ends + end + + + + + \ No newline at end of file diff --git a/cread.asm b/cread.asm new file mode 100644 index 0000000..8623835 --- /dev/null +++ b/cread.asm @@ -0,0 +1,885 @@ +; =====> CREAD.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* S-Expression reading * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* Last Modification: 10 Feb 1987 * +;* * +;* tc 2/10/87 fix to convert first * +;* char after # to upper case * +;* tc 2/10/87 added support to do * +;* readline * +;*************************************** + page 60,132 + include scheme.equ + include sinterp.arg + +SPACE equ 20h +CTRL_Z equ 1Ah +LINEFEED equ 0Ah +RETURN equ 0Dh +COM equ 3Bh +BK_SLASH equ 5Ch +BUFSIZE equ 256 +TEST_NUM equ 8 +EOFERR equ 1 +SHARPERR equ 7 +PORTERR equ -2 +HEAPERR equ -3 + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public test_ch, t_array + extrn locases:word + extrn hicases:word + extrn CXFERR_s:word + extrn port_r:word +srd_str db "READ-ATOM",0 +sln_str db "READ-LINE",0 +inv_char db "Invalid character constant",0 +limit dw ? ; current size of atom buffer +main_reg dw ? ; main register +flg_eof dw ? ; whether to flag end-of-file +atomb dw ? ; atom buffer +test_ch db 0Ah,20h,7Fh,0Ch,09h,08h,0Dh,1Bh ; special characters +char db 20h ; most recently received char +t_str1 db "NEWLINE",0 +t_str2 db "SPACE",0 +t_str3 db "RUBOUT",0 +t_str4 db "PAGE",0 +t_str5 db "TAB",0 +t_str6 db "BACKSPACE",0 +t_str7 db "RETURN",0 +t_str8 db "ESCAPE",0 +t_array dw t_str1 + dw t_str2 + dw t_str3 + dw t_str4 + dw t_str5 + dw t_str6 + dw t_str7 + dw t_str8 +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +;;;*************************************************************************** +;;; Support for read-line +;;;*************************************************************************** +rln_proc proc + extrn next_SP:near + extrn src_err:near + + public srd_line +srd_line: lods byte ptr ES:[SI] + save + add AX,offset reg0 ; compute register address + mov main_reg,AX + xor BX,BX + push BX + push AX + C_call get_port,,Load_ES ; get the port object + mov SP,BP ; get the return status + test AX,AX ; error returned? + jnz srd_lerr + pushm + call sread_ln ; get a line + mov SP,BP + jmp next_SP ; return to interpreter +; +srd_lerr: lea BX,sln_str + jmp src_err ; link to error handler +rln_proc endp + +;;;*************************************************************************** +;;; Set up for the operation of reading a single line from the given port. +;;;*************************************************************************** + extrn setabort:near + extrn abort:near + extrn ssetadr:near +srdlnarg struc +temp_r dw ? ; temporary storage +srdln_BP dw ? ; caller's BP + dw ? ; caller's return address +rp_reg dw ? ; port register +rpg dw ? ; adjusted page number +rdisp dw ? ; displacement +srdlnarg ends +; + public sread_at +sread_ln proc near + push BP + sub SP, offset srdln_BP ; allocate local storage + mov BP,SP + call setabort ; save stack pointer + pushm <[BP].rdisp,[BP].rpg> + call ssetadr ; set port address + mov SP,BP + test AX,AX ; check return status + jz srdl_010 + mov AX,PORTERR ; port error + push AX + call abort +; + mov flg_eof,1 ; flag eof +srdl_010: + call rcvchar ; get char, eof won't return here + cmp AL,LINEFEED ; is char linefeed? + je srdl_010 ; if so, ignore + + mov [BP].temp_r,AX ; save character read + + mov AX,BUFSIZE ; Get buffer size + mov limit,AX + push AX + C_call getmem ; allocate buffer + mov SP,BP + cmp AX,0 ; memory available? + jne srdl_020 +;error allocate C heap space + mov AX,HEAPERR ; no, error + push AX + call abortrea + mov SP,BP + jmp srdln_ret + +srdl_020: mov SI,AX + mov atomb,AX ; address of buffer + mov flg_eof,0 ; don't flag error on EOF + xor BX,BX ; index into buffer + mov AX,[BP].temp_r ; restore saved character +; read characters +srdln_cha: + cmp AL,RETURN ; Return character? + je srdln_ret ; yes, return + cmp AL,CTRL_Z ; EOF character? + je srdln_ret ; yes, return + cmp AL,LINEFEED ; Linefeed character? + je srdln_ret ; yes, don't put in atomb + + pushm + call addchar ; Add character to buffer + mov SP,BP + inc BX +srdln_nxt: + call rcvchar ; Get next character + jmp srdln_cha ; Go get next character + +srdln_ret: + mov CX,STRTYPE ; Allocate string data type + mov [BP].temp_r,BX + pushm + c_call alloc_bl,,Load_ES + mov SP,BP + mov CX,3 ; Copy buffer to Scheme string + mov SI,atomb + pushm <[BP].temp_r,SI,CX,main_reg> + call toblock + mov AX,limit ; Release buffer + pushm + C_call rlsmem + mov SP,BP + mov flg_eof,1 ; Reset flags + mov limit,0 + add SP,offset srdln_BP ; Deallocate local storage + pop BP + ret ; Return +sread_ln endp + +;;;*************************************************************************** +;;; Support for read-atom +;;;*************************************************************************** +rds_proc proc + extrn next_SP:near + extrn src_err:near + + public srd_atom +srd_atom: lods byte ptr ES:[SI] + save + add AX,offset reg0 ; compute register address + mov main_reg,AX + xor BX,BX + push BX + push AX + C_call get_port,,Load_ES ; get the port object + mov SP,BP ; get the return status + test AX,AX ; error returned? + jnz srd_err + pushm + call sread_at ; sread_atom() + mov SP,BP + jmp next_SP ; return to interpreter +; +srd_err: lea BX,srd_str + jmp src_err ; link to error handler +rds_proc endp + +;;;*************************************************************************** +;;; Set up for the operation of reading a single atom from the given port. +;;; Special characters such as ')' are parsed as lists(!) to tell them from +;;; ordianry atoms. +;;;*************************************************************************** + extrn setabort:near + extrn abort:near + extrn ssetadr:near +sreadarg struc + dw ? ; caller's BP + dw ? ; caller's return address +p_reg dw ? ; port register +pg dw ? ; adjusted page number +disp dw ? ; displacement +sreadarg ends +; + public sread_at +sread_at proc near + push BP + mov BP,SP + call setabort ; save stack pointer + pushm <[BP].disp,[BP].pg> + call ssetadr ; set port address + mov SP,BP + test AX,AX ; check return status + jz srd_010 + mov AX,PORTERR ; port error + push AX + call abort +; +srd_010: mov flg_eof,1 ; initialization + mov limit,0 +; skip spaces +srd_spa: call rcvchar + call ck_space ; check for space + test CX,CX + jz srd_spa ; yes, skip +; skip comments +srd_com: cmp AL,COM ; check for comment + jne srd_at +srd_c10: call rcvchar + cmp AL,RETURN + jne srd_c10 ; yes, ignore the whole line + jmp srd_spa +; +srd_at: test AL,AL ; null character? + jz srd_spa + call read_ato + pop BP + ret +sread_at endp + +;;;*************************************************************************** +;;; Fetch one character from the input stream +;;;*************************************************************************** + extrn take_ch:near +rcvchar proc near + pop DX ; fetch return address +; + push DX ; save registers + push SI + push DI + push CX + push BX + call take_ch ; takechar() + pop BX ; restore registers + pop CX + pop DI + pop SI + pop DX +; Check the character + cmp AX,256 + jge rcv_10 + cmp AL,CTRL_Z ; EOF character? + je rcv_10 ; yes, jump + mov char,AL + jmp DX ; return to caller +; EOF character is fetched +rcv_10: cmp flg_eof,0 ; EOF flag set? + jne rcv_20 ; yes, error + mov AX,CTRL_Z + mov char,AL + jmp DX ; return to caller +; +rcv_20: mov AX,EOFERR + push AX + call abortrea ; abortread(EOFERR) +rcvchar endp + +;;;*************************************************************************** +;;; Read in an atom (symbol, string, number) +;;; Store the pointer to the atom in REG. +;;; Special characters such as ')' or ',' are read as atoms themselves. +;;; Normal atoms will end in a whitespace or a terminating macro character; +;;; strings end with the closing '"'. +;;; Numbers in the requested base are interpreted as such. +;;; On exit, the next character in the buffer is the one following the last +;;; character of the atom. +;;;*************************************************************************** + extrn toblock:near + extrn cons:near + extrn buildint:near + extrn alloc_st:near + extrn scannum:near + extrn pushchar:near + +readarg struc +num_base dw ? ; base of number +tmpreg dw ? +inputch dw ? ; whether the #\ macro is in effect +escaped dw ? ; whether an escape char is used +inflo dq ? ; for floating point value +bignum dw ? +biglimit dw ? +read_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +readarg ends +; +read_ato proc near + push ES + push BP + sub SP,offset read_BP ; allocate local storage + mov BP,SP + xor CX,CX + mov [BP].tmpreg,AX +;;; cmp AL,SPACE ; check for space? +;;; jne read_at +;;; mov [DI].C_page,CX ; yes, form NIL and return +;;; mov [DI].C_disp,CX +;;; jmp read_end +read_at: mov flg_eof,CX ; initialization + mov [BP].inputch,CX + mov [BP].escaped,CX + mov CXFERR_s,CX + mov AX,BUFSIZE + mov limit,AX + mov [BP].num_base,10 + push AX + C_call getmem ; allocate memory + mov SP,BP + cmp AX,0 ; memory available? + jne read_01 +memerr: mov AX,HEAPERR ; no, error + push AX + call abortrea + mov SP,BP + jmp read_ret +read_01: mov SI,AX + mov atomb,AX ; save the address of atom buffer + mov DI,main_reg + xor BX,BX + mov AX,[BP].tmpreg +; check for the special character first + cmp AL,5Bh ; [ + je read_10 + cmp AL,5Dh ; ] + je read_10 + cmp AL,7Bh ; { + je read_10 + cmp AL,7Dh ; } + je read_10 + cmp AL,28h ; ( + je read_10 + cmp AL,29h ; ) + je read_10 + cmp AL,27h ; ' + je read_10 + cmp AL,60h ; ` + jne read_st +; special character case +read_10: mov [SI],AL ; *atomb = ch + inc BX + jmp read_sp +; +read_st: cmp AL,22h ; " + jne read_co +; string case + push AX + call delimby ; get the string + mov SP,BP + mov [BP].tmpreg,BX ; save BX register + mov CX,STRTYPE + pushm + C_call alloc_bl,,Load_ES ; allocate string object + mov SP,BP + mov CX,3 + mov SI,atomb + pushm <[BP].tmpreg,SI,CX,main_reg> + call toblock ; copy string to string object + jmp read_bye +; +read_co: cmp AL,2Ch ; , + jne read_mac +; comma case + mov [SI],AL + inc BX + call rcvchar ; get the next character + cmp AL,40h ; check for @ + je read_20 + cmp AL,2Eh ; check for . + je read_20 + jmp read_nor +read_20: mov [SI+BX],AL + inc BX + jmp read_sp +; +read_mac: cmp AL,23h ; # + je read_25 + jmp read_sym +; macro case +read_25: mov flg_eof,1 +read_30: test BX,BX ; first character? + jz read_34 +read_32: jmp read_200 ; no, jump +; +read_34: cmp AL,23h ; # + jne read_32 ; no, jump + call rcvchar ; get the next character + call ck_space ; check for space + test CX,CX + jnz read_40 +read_35: mov AX,SHARPERR ; yes, error + push AX + call abortrea +; +read_40: mov byte ptr [SI+1],AL ; save the character + push BX + mov BX,offset locases ; address of lower-case characters + xlat + pop BX ; restore registers + cmp AL,62h ; b? + jne read_d + mov [BP].num_base,2 + jmp read_100 +; +read_d: cmp AL,64h ; d? + jne read_x + mov [BP].num_base,10 + jmp read_100 +; +read_x: cmp AL,78h ; x? + je read_50 + cmp AL,68h ; h? + jne read_o +read_50: mov [BP].num_base,16 + jmp read_100 +; +read_o: cmp AL,6Fh ; o? + jne read_ba + mov [BP].num_base,8 + jmp read_100 +; +read_ba: cmp AL,BK_SLASH ; \? + jne read_i + call rcvchar + pushm + call addchar + mov SP,BP + inc BX + mov [BP].inputch,1 + mov [BP].escaped,1 + jmp read_100 +; +read_i: cmp AL,69h ; i? + je read_100 + cmp AL,65h ; e? + je read_100 + cmp AL,73h ; s? + je read_100 + cmp AL,6Ch ; l? + je read_100 + cmp AL,3Ch ; + call addchar + mov SP,BP + inc BX +read_250: call rcvchar ; get the next character + jmp read_sym +; +read_en: xor AL,AL ; put null at end of token + pushm + call addchar + mov SP,BP +; Check for single, unescaped dot + cmp BX,1 + jne read_num + cmp byte ptr [SI],2Eh ; check for . + jne read_num + cmp [BP].escaped,1 + je read_num + jmp read_nor +; At this point a token has been accumulated, check for number +read_num: mov [BP].tmpreg,BX ; save BX register + push [BP].num_base + push SI + call scannum ; scan number + mov SP,BP + mov SI,atomb ; restore SI register + mov BX,[BP].tmpreg ; restore BX register + test AX,AX ; number or not? + jnz read_n05 + jmp read_500 +read_n05: cmp [BP].escaped,1 + jne read_n07 + jmp read_500 +read_n07: cmp AX,0 + jle read_300 ; negative for floating point number +; integer of some size + add AX,9 ; (AX + 9) / 2 + shr AX,1 ; AX = bytes needed for integer + mov [BP].biglimit,AX ; save for later + push AX + C_call getmem ; allocate memory for bignum + mov SP,BP + cmp AX,0 ; memory available? + jne read_n10 + jmp memerr ; no, error +read_n10: mov BX,AX + mov [BP].bignum,AX + mov byte ptr [BX+3],0 + mov byte ptr [BX+4],0 + pushm <[BP].num_base, atomb, BX> + call buildint ; form integer + mov SP,BP + mov DI,main_reg + mov BX,[BP].bignum + pushm + C_call alloc_in,,Load_ES ; alloc_int + mov SP,BP + pushm <[BP].biglimit,[BP].bignum> + C_call rlsmem ; release memory for bignum + mov SP,BP + jmp read_rls +; Floating point number +read_300: lea DX,[BP].inflo + pushm <[BP].num_base, DX, SI> + C_call scanflo,,Load_ES ; scan the flonum + mov SP,BP + mov DI,main_reg + lea BX,[BP].inflo + pushm <[BX+6],[BX+4],[BX+2],[BX]> ; push flonum value + push DI + C_call alloc_fl,,Load_ES ; alloc_flonum + mov SP,BP + jmp read_rls +; Allocate character or interned symbol +read_500: cmp [BP].inputch,0 ; #\ macro? + mov DI,main_reg + jne read_510 + jmp read_600 ; no, symbol +read_510: mov [DI].C_page,SPECCHAR*2 + cmp BX,1 ; only one character? + jne read_mul ; no, jump + xor AH,AH + mov AL,byte ptr [SI] + mov [DI].C_disp,AX ; return the character + jmp read_rls +; Check for a multichar character constant +read_mul: mov AL,byte ptr [SI] + mov BX,offset hicases ; address of higher-case characters + xlat + mov byte ptr [SI],AL + xor BX,BX +read_515: cmp BL,TEST_NUM ; finish the comparison? + je read_580 ; yes, jump + lea DI,t_array ; save BX register + mov CX,BX + shl BX,1 ; get the word offset + mov DI,word ptr [DI+BX] ; address of special string + xor BX,BX +read_520: mov AL,byte ptr [DI+BX] ; get the character in string + cmp AL,0 ; end of string + je read_530 ; match + cmp byte ptr [SI+BX],AL + jne read_540 + inc BX + jmp read_520 +read_530: mov BX,CX + lea SI,test_ch ; address of special characters + mov AL,byte ptr [SI+BX] + mov DI,main_reg + mov [DI].C_disp,AX ; return the special character + jmp read_rls +; +read_540: mov BX,CX + inc BX + jmp read_515 +; For the unrecognized multi-char character constant, return #\? +read_580: mov DI,main_reg + mov [DI].C_disp,3Fh ; return '?' character +;;; push SI +;;; lea BX,tmp_reg +;;; push BX +;;; C_call alloc_st,,Load_ES ; alloc_string for error message +;;; mov SP,BP +;;; lea BX,tmp_reg +;;; push BX +;;; lea BX,inv_char +;;; push BX +;;; xor BX,BX +;;; push BX +;;; C_call set_erro,,Load_ES ; set_error +;;; mov SP,BP + mov CXFERR_s,-1 ; error status + jmp read_rls +; Not a character, but a symbol +read_600: push BX ; length of symbol + push SI ; address of symbol + push DI ; register + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + jmp read_rls +; +read_sp: pushm + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + lea BX,nil_reg + mov DI,main_reg + pushm + call cons ; encase in a list + mov SP,BP + jmp read_bye +; +read_nor: pushm + C_call intern,,Load_ES ; intern the symbol + mov SP,BP + lea BX,nil_reg + mov DI,main_reg + pushm + call cons ; encase in a list + mov SP,BP +read_rls: cmp char,CTRL_Z ; EOF character? + je read_bye + call pushchar ; put post-atom char back to buffer +; +read_bye: mov AX,limit + pushm + C_call rlsmem ; release memory + mov SP,BP + mov flg_eof,1 ; reset flags + mov limit,0 +; +read_end: mov AX,CXFERR_s ; return status +read_ret: add SP,offset read_BP ; release local storage + pop BP + pop ES + ret +read_ato endp + +;;;************************************************************************ +;;; DELIMBY(c) +;;; DELIMBY takes characters from the input stream and places them +;;; in the buffer ATOMB, starting at offset stored in BX register, and +;;; ending when the delimiting character C is reached. +;;; Note: SI = address of atomb +;;; BX = number of characters in atomb +;;;************************************************************************ +deliarg struc + dw ? ; caller's BP + dw ? ; caller's return address +cha dw ? ; character +deliarg ends + +delimby proc near + push BP ; get the return address + mov BP,SP + mov flg_eof,1 ; signal the EOF error + call rcvchar +deli_10: mov CX,[BP].cha + cmp AL,CL ; reach the end? + je deli_50 ; yes, return + cmp AL,RETURN ; carriage return? + je deli_40 ; yes, ignore + cmp AL,BK_SLASH ; check for \ + jne deli_30 + call rcvchar ; yes, ignore +deli_30: pushm + call addchar + mov SP,BP + inc BX +deli_40: call rcvchar ; get the next character + jmp deli_10 +deli_50: mov flg_eof,0 + pop BP + ret +delimby endp + +;;;************************************************************************ +;;; ADDCHAR (i, c) +;;; ADDCHAR takes the character c and places it in the dynamic +;;; atom buffer atomb, at offset i. If the buffer can not contain +;;; any more characters, additional space is allocated, and limit +;;; is adjusted accordingly. +;;;************************************************************************ +addarg struc +add_tmp dw ? +add_BP dw ? ; caller's BP + dw ? ; caller's return address +index dw ? +chara dw ? +addarg ends + +addchar proc near + push BP + sub SP,offset add_BP ; allocate local storage + mov BP,SP + mov BX,[BP].index + cmp BX,limit ; room for character? + jge add_10 ; no, jump +add_01: mov AX,[BP].chara + mov byte ptr [SI+BX],AL +add_ret: add SP,offset add_BP + pop BP + ret +add_10: mov AX,limit + add AX,BUFSIZE + push AX + C_call getmem ; allocate memory + mov SP,BP + cmp AX,0 ; memory available? + jne add_20 + mov AX,HEAPERR ; no, error + push AX + call abortrea + mov SP,BP + jmp add_ret +add_20: mov DI,AX ; address of new buffer + mov SI,atomb + mov CX,limit +rep movsb ; copy characters + mov [BP].add_tmp,AX ; save buffer pointer + pushm + C_call rlsmem ; discard the old buffer + mov SP,BP + mov SI,[BP].add_tmp + mov atomb,SI + mov CX,limit + add CX,BUFSIZE ; increase the limit + mov limit,CX + mov BX,[BP].index + jmp add_01 +addchar endp + +;;;************************************************************************ +;;; ABORTREAD(code) +;;; Cancels the entire read operation via ABORT, after +;;; resetting some vital registers. +;;; Note: DI = address of main register +;;;************************************************************************ +abortarg struc + dw ? ; caller's BP + dw ? ; caller's return address +errcode dw ? ; error code +abortarg ends + +abortrea proc near + push BP + mov BP,SP + mov DI,main_reg ; main register + cmp [BP].errcode,EOFERR ; EOF error? + jne ab_010 + mov [DI].C_page,EOF_PAGE*2 ; return eof indicator + mov [DI].C_disp,EOF_DISP + jmp ab_020 +; +ab_010: xor AX,AX + mov [DI].C_page,AX ; NUL main register + mov [DI].C_disp,AX +; +ab_020: push [BP].errcode + call abort + pop BP + ret +abortrea endp + +;;;********************************************************************** +;;; Local support to check the character in AX is space or not +;;; Note: CX = 0 iff the character is whitespace +;;;********************************************************************** +ck_space proc near + pop DX ; get the return address + xor CX,CX + cmp AL,SPACE ; space? + je is + cmp AL,9 + jb isnot + cmp AL,0Dh + jbe is +isnot: inc CX +is: jmp DX ; return to caller +ck_space endp +prog ends + end + + \ No newline at end of file diff --git a/cwindow.asm b/cwindow.asm new file mode 100644 index 0000000..aaea722 --- /dev/null +++ b/cwindow.asm @@ -0,0 +1,553 @@ +; =====> CWINDOW.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* Window I/O support * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* Last Modification: 24 March 1986 * +;* 7 Jan 1987 - dbs * +;* added random I/O * +;*************************************** + page 60,132 + include scheme.equ + include sinterp.arg + +BUFFSIZE equ 256 ; input/output buffer +WINDSIZE equ 32-BLK_OVHD +PORTATTR equ 62 +LABEL equ 32+BUFFSIZE ; window label field +P_FLAGS equ 6 +W_FLAGS equ 26 +WINDOW equ 4 +B_ATTR equ 22 +T_ATTR equ 24 +CUR_LINE equ 10 +CUR_COL equ 12 +UL_LINE equ 14 +UL_COL equ 16 +N_LINES equ 18 +N_COLS equ 20 +NUM_FLDS equ 12 +CHUNK equ 14 +STR_PTR equ 3 +OPEN equ 8 + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public MAX_ROWS,MAX_COLS +; from ???? + extrn port_r:word + +bad_port db "[VM INTERNAL ERROR] Bad port for window output",CR,LF,0 +mk_win_st db "%MAKE_WINDOW",0 +sv_win_st db "WINDOW-SAVE-CONTENTS",0 +rt_win_st db "WINDOW-RESTORE-CONTENTS",0 +gt_win_st db "%REIFY-PORT",0 +cl_win_st db "WINDOW_CLEAR",0 + +defaults dw 0,0,0,0 ; default values of window object +max_rows db 25,0 +max_cols db 80,0 + dw -1,15,1,0,0 + +wnlines dw 0 ; number of lines +wncols dw 0 ; number of columns +wulline dw 0 ; upper-left line number +wulcol dw 0 ; upper-left column number +branchtab dw setw_20 ; [0] : cursor line + dw setw_20 ; [1] : cursor column + dw setw_30 ; [2] : upper left corner line + dw setw_40 ; [3] : upper left corner column + dw setw_50 ; [4] : number of lines + dw setw_60 ; [5] : number of columns + dw setw_100 ; [6] : border attribute + dw setw_100 ; [7] : text attribute + dw setw_100 ; [8] : flags + dw setw_100 ; [9] : buffer position + dw setw_100 ; [10] : buffer end + dw setw_100 ; [11] : port flag + dw setw_70 ; [12] : # of chunks +data ends + +XGROUP group progx +progx segment word public 'progx' + extrn rest%scr:far + extrn save%scr:far +progx ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +win_proc proc near +;;;************************************************************************ +;;; Allocate a window object +;;;************************************************************************ + extrn zero_blk:near + extrn next_SP:near + extrn src_err:near + extrn adj4bord:near + public make_win +make_win: lods byte ptr ES:[SI] ; load the operand register + save + add AX,offset reg0 ; compute register address + mov BX,AX + mov SI,[BX].C_disp ; get displacement + mov BX,[BX].C_page ; get page number + mov tmp_disp,SI ; save window label pointer + mov tmp_page,BX + cmp byte ptr ptype+[BX],STRTYPE*2 ; check string type + jne make_err + jmp short make_020 + +make_err: test BX,BX + jz make_020 ; null window label + lea BX,mk_win_st ; load address of text + jmp src_err ; display error message + +make_020: mov BX,BUFFSIZE+WINDSIZE ; get object length + mov CX,PORTTYPE ; port type + pushm + C_call alloc_bl,,Load_ES ; allocate block for window object + pop BX + mov DI,[BX].C_disp ; get displacement + save + mov BX,[BX].C_page ; get page numbe of window object + LoadPage ES,BX ; get page address + shr BX,1 + pushm + call zero_blk ; zero window object + restore + mov word ptr ES:[DI+6],PORTATTR ; store port attribute + mov AX,DI + add DI,10 ; position to move default values + lea SI,defaults ; address of default values + mov CX,NUM_FLDS-1 ; length of defaults +rep movsw ; move defaults into object + mov DI,AX + mov AX,tmp_page + mov BX,tmp_disp + mov byte ptr ES:[DI+STR_PTR],AL ; store window label pointer + mov word ptr ES:[DI+STR_PTR+1],BX + jmp next_SP +;;;************************************************************************ +;;; Get Window Attributes +;;; Get Window Attributes was translated from C. The following C comments +;;; show the mappings of the arguments to get-window-attributes to their +;;; actual locations within the port object. +;;; +;;; +;;;#define NUM_FIELDS 12 +;;;static int defaults[NUM_FIELDS] = {0, /* cursor line number */ +;;; 0, /* cursor column number */ +;;; 0, /* upper left corner line number */ +;;; 0, /* upper left corner column number */ +;;; 25, /* number of lines */ +;;; 80, /* number of columns */ +;;; -1, /* no border */ +;;; 15, /* text high intensity, enable */ +;;; 1, /* wrap enabled */ +;;; 0, /* current buffer position */ +;;; 0, /* current buffer end */ +;;;TRANSCRIPT+BINARY+WINDOW+OPEN+READ_WRITE}; /* port attributes */ +;;;static int map_attr[NUM_FIELDS] = {10,12,14,16,18,20,22,24,26,28,30,6}; +;;; +;;;************************************************************************ + public get_wind +get_wind: lods word ptr ES:[SI] ; load register operand + save ; save the location pointer + xor BX,BX + mov BL,AH + add BX,offset reg0 ; compute address of register + xor AH,AH + add AX,offset reg0 + save ; save registers + save + mov CX,1 + pushm + C_call get_port,,Load_ES ; get the port object + mov SP,BP + mov SI,tmp_page + cmp byte ptr ptype+[SI],PORTTYPE*2 + jne get_err + restore + cmp [BX].C_page,SPECFIX*2 + jne get_err + mov BX,word ptr [BX].C_disp ; get the value + shl BX,1 + sar BX,1 + cmp BX,0 + jl get_err + cmp BX,NUM_FLDS + jg get_err ; used to be jge - dbs + LoadPage ES,SI ; get page address + mov SI,tmp_disp + restore + mov DI,AX + mov word ptr [DI].C_page,SPECFIX*2 + cmp BX,12 + jne get_05 + mov AX,word ptr ES:[SI+CHUNK]; get chunk number + jmp get_20 +get_05: cmp BX,11 + jne get_10 + mov AX,word ptr ES:[SI+6] + jmp get_20 +get_10: shl BX,1 ; get the word offset + mov AX,word ptr ES:[SI+10+BX] +get_20: + test word ptr ES:[SI+P_FLAGS],WINDOW ; Port a window? + jz get_25 ; No, jump + and AX,07FFFh ; Yes, return integer + mov word ptr [DI].C_disp,AX + jmp next_SP ; Return to interpreter +get_25: + xor BX,BX + push BX ; push long integer value + push AX + push DI ; register to store value + C_call long2int,,Load_ES ; convert to scheme integer + mov SP,BP + jmp next_SP +get_err: lea BX,gt_win_st + jmp src_err ; link to error handler +;;;************************************************************************ +;;; Modify Transcript File Status +;;;************************************************************************ + public trns_chg +trns_chg: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; compute address of register + mov BX,AX + mov SI,[BX].C_disp + mov BX,[BX].C_page + cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type + jne trns_10 + LoadPage ES,BX ; get page address + mov AX,word ptr ES:[SI+P_FLAGS] + mov CX,AX + and AX,OPEN ; open? + jz trns_10 + and CX,3 ; read and write? + jz trns_10 + mov TRNS_pag,BX + mov TRNS_dis,SI + jmp next_SP +trns_10: xor AX,AX + mov TRNS_pag,AX + mov TRNS_dis,AX + jmp next_SP +;;;************************************************************************ +;;; Save Window Contents +;;;************************************************************************ + public save_win +save_win: lods byte ptr ES:[SI] ; load register operand + save + add AX,offset reg0 ; compute address of register + xor BX,BX + pushm + save + C_call get_port,,Load_ES ; get port object + mov SP,BP + mov BX,tmp_page + cmp byte ptr ptype+[BX],PORTTYPE*2 ; check port type + je save_01 +save_err: lea BX,sv_win_st + jmp src_err ; link to error handler +save_01: LoadPage ES,BX ; get page address + mov DI,tmp_disp + mov AX,word ptr ES:[DI+P_FLAGS] + and AX,WINDOW ; window object? + jz save_err + mov AX,word ptr ES:[DI+UL_LINE] + mov BX,word ptr ES:[DI+UL_COL] + mov CX,word ptr ES:[DI+N_LINES] + mov DX,word ptr ES:[DI+N_COLS] + mov wulline,AX + mov wulcol,BX + mov wnlines,CX + mov wncols,DX + mov AX,word ptr ES:[DI+B_ATTR] ; border attribute + cmp AX,-1 ; bordered? + je save_10 ; no, jump + lea AX,wulline + lea BX,wulcol + lea CX,wnlines + lea DX,wncols + pushm + call adj4bord ; adjust window region +save_10: mov AX,wnlines + mov BX,wncols +; compute the length of string to save window contents + mul BL + shl AX,1 ; * 2 + add AX,2 ; + 2 + push AX + restore + mov CX,STRTYPE ; string type + pushm + C_call alloc_bl,,Load_ES ; alloc_block + mov SP,BP + pushm + restore + push AX + call save%scr ; save screen + jmp next_SP ; return to interpreter +;;;************************************************************************ +;;; Restore Window Contents +;;;************************************************************************ + public rest_win +rest_win: lods word ptr ES:[SI] ; load register operand + save ; save the location pointer + xor BX,BX + mov BL,AH + add BX,offset reg0 ; compute address of register + xor AH,AH + add AX,offset reg0 + save + xor CX,CX + pushm + C_call get_port,,Load_ES ; get the port object + mov SP,BP + restore ; BX = data to be restored + mov SI,[BX].C_page + cmp byte ptr ptype+[SI],STRTYPE*2 ; check type + jne rest_err + mov DI,tmp_page + cmp byte ptr ptype+[DI],PORTTYPE*2 ; check type + jne rest_err + LoadPage ES,DI ; get page address + mov DI,tmp_disp + mov AX,word ptr ES:[DI+P_FLAGS] + and AX,WINDOW ; window object? + jz rest_err + mov AX,word ptr ES:[DI+UL_LINE] + mov BX,word ptr ES:[DI+UL_COL] + mov CX,word ptr ES:[DI+N_LINES] + mov DX,word ptr ES:[DI+N_COLS] + mov wulline,AX + mov wulcol,BX + mov wnlines,CX + mov wncols,DX + mov AX,word ptr ES:[DI+B_ATTR] ; border attribute + cmp AX,-1 + je rest_10 + lea AX,wulline + lea BX,wulcol + lea CX,wnlines + lea DX,wncols + pushm + call adj4bord ; adjust window region +rest_10: pushm + restore + push BX + call rest%scr ; restore screen + jmp next_SP ; return to interpreter +rest_err: lea BX,rt_win_st + jmp src_err ; link to error handler +win_proc endp +;;;************************************************************************ +;;; Set Window Attribute +;;;************************************************************************ +setw_arg struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +setw_reg dw ? +setw_att dw ? +setw_val dw ? +setw_arg ends + public set_wind +set_wind proc near + push ES + push BP + mov BP,SP + mov AX,1 + pushm + C_call get_port,,Load_ES ; get port address + mov SP,BP + mov BX,tmp_page + cmp byte ptr ptype+[BX],PORTTYPE*2 ; check type + jne setw_err + mov SI,[BP].setw_att + cmp word ptr [SI].C_page,SPECFIX*2 ; check attribute type + jne setw_err + mov AX,[SI].C_disp ; get attribute value + shl AX,1 + sar AX,1 + cmp AX,0 ; check attribute value + jl setw_err + cmp AX,NUM_FLDS + jge setw_err + mov SI,[BP].setw_val ; get the value pointer + cmp word ptr [SI].C_page,SPECFIX*2 ; check type + je setw_10 +setw_err: lea BX,gt_win_st ; address of error message + pushm <[BP].setw_val, [BP].setw_att, [BP].setw_reg> + mov AX,3 + pushm + C_call set_src_,,Load_ES ; set_src_err + mov SP,BP + mov AX,-1 ; return error status + jmp setw_ret +setw_10: mov CX,[SI].C_disp ; get the value + shl CX,1 + sar CX,1 + LoadPage ES,BX ; get page address of port + mov SI,tmp_disp ; displacement of port object + mov BX,AX + shl BX,1 ; get the word offset + jmp branchtab+[BX] +; cursor line/cursor column +setw_20: cmp CX,0 + jl setw_err ; negative value, error + jmp setw_100 +; upper left hand corner line number +setw_30: xor AX,AX + xor DH,DH + mov DL,MAX_ROWS + dec DX ; MAX_ROWS - 1 + call fit_in_r + mov AX,word ptr ES:[SI+N_LINES] + inc DX + sub DX,CX ; MAX_ROWS - value + cmp AX,DX + jle setw_35 + mov word ptr ES:[SI+N_LINES],DX +setw_35: jmp setw_100 +; upper left hand corner column number +setw_40: xor AX,AX + xor DH,DH + mov DL,MAX_COLS + dec DX ; MAX_COLUMNS - 1 + call fit_in_r + mov AX,word ptr ES:[SI+N_COLS] + inc DX + sub DX,CX ; MAX_COLUMNS - value + cmp AX,DX + jle setw_35 + mov word ptr ES:[SI+N_COLS],DX + jmp setw_35 +; number of lines +setw_50: mov AX,word ptr ES:[SI+UL_LINE] + xor DH,DH + mov DL,MAX_ROWS + sub DX,AX ; MAX_ROWS - UL_LINE + mov AX,1 + call fit_in_r + jmp setw_100 +; number of columns +setw_60: mov AX,word ptr ES:[SI+P_FLAGS] + and AX,WINDOW ; window? + jz setw_100 ; no, jump + mov AX,word ptr ES:[SI+UL_COL] + xor DH,DH + mov DL,MAX_COLS + sub DX,AX ; MAX_COLUMNS - UL_COL + mov AX,1 + call fit_in_r + jmp setw_100 +; chunk# +setw_70: mov BX,CHUNK + jmp setw_120 +; store the value +setw_100: sar BX,1 + cmp BX,11 + jne setw_110 + mov BX,6 + jmp setw_120 +setw_110: shl BX,1 ; word offset + add BX,10 +setw_120: mov word ptr ES:[SI+BX],CX ; store the value + xor AX,AX +setw_ret: pop BP + pop ES + ret +set_wind endp +;;;************************************************************************ +;;; Force Value into Range +;;; Purpose: To test a value (in CX) to determine if it falls within a +;;; range of values, as specified by an lower (in AX) and +;;; upper (in DX) bounds. If the value is within the range, +;;; the value is returned (in CX) unchanged. If it is outside +;;; the range, the value of the endpoint nearest its value +;;; is returned (in CX). +;;;************************************************************************ +fit_in_r proc near + pop DI ; get the return address + cmp CX,AX ; value < lower? + jge fit_10 + mov CX,AX ; yes, return lower +fit_01: jmp DI ; return to caller +fit_10: cmp CX,DX ; value > upper? + jle fit_01 ; no, return + mov CX,DX ; yes, return upper + jmp DI ; return to caller +fit_in_r endp +;;;************************************************************************ +;;; Write message to the who-line +;;;************************************************************************ +who_arg struc +pg dw ? +dis dw ? +who_BP dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; caller's return address +str dw ? ; pointer to message string +who_arg ends + extrn ssetadr:near + extrn printstr:near + public who_writ +who_writ proc near + push ES + push BP + sub SP,offset who_BP ; allocate local storage + mov BP,SP + lea SI,port_r + mov AX,[SI].C_page + mov [BP].pg,AX + mov AX,[SI].C_disp + mov [BP].dis,AX + mov AX,WHO_DISP + mov BX,WHO_PAGE*2 + pushm + call ssetadr ; get port address + mov SP,BP +; compute the length of message string + xor BX,BX + mov SI,[BP].str +who_010: cmp byte ptr [SI+BX],0 ; end of string? + je who_020 + inc BX + jmp who_010 +; Write message to the who line +who_020: push BX ; BX = strlen(str) + push SI + call printstr + mov SP,BP +; Restore the port which was in effect when started + mov BX,[BP].pg + cmp byte ptr ptype+[BX],PORTTYPE*2 ; check port type + jne who_ret + LoadPage ES,BX ; get page address + mov SI,[BP].dis + cmp byte ptr ES:[SI],PORTTYPE ; check port type + jne who_ret + pushm + call ssetadr ; get port address + mov SP,BP +who_ret: add SP,offset who_BP ; release local storage + pop BP + pop ES + ret +who_writ endp + +prog ends + end + + \ No newline at end of file diff --git a/expsmmu.asm b/expsmmu.asm new file mode 100644 index 0000000..0296d6c --- /dev/null +++ b/expsmmu.asm @@ -0,0 +1,534 @@ + name EXPSMMU + title Scheme Memory Management Utilities for Expanded Memory + page 62,132 +; =====> EXPSMMU.ASM +;**************************************************************** +;* TIPC Scheme '84 Memory Management Utilities * +;* * +;* (C) Copyright 1985 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Author: Terry Caudill * +;* Date written: 18 March 1986 * +;* Modifications: * +;* tc 3/16/87 Better error handling for mapping errors and * +;* fix to requiring page frame on 64k boundary * +;* rb 4/5/87 "getbase" modified to return a page's swap * +;* status in the carry bit * +;**************************************************************** + include schemed.equ + include schemed.ref + include schemed.mac + +DOS equ 021h +EMM_DSR equ 67h ;; EMM DSR Interrupt + +;; EMM DSR Function Requests + +EMM_Status equ 40h ;; Get status of EMM +EMM_FrameAddr equ 41h ;; Get segment of page frame +EMM_PageCount equ 42h ;; How many pages available +EMM_Allocate equ 43h ;; Allocate pages +EMM_MapPage equ 44h ;; Map page into page frame +EMM_Dealloc equ 45h ;; Deallocate PCS'S expanded mem pages + +DGROUP group data +PGROUP group prog + +data segment word public 'DATA' + assume ds:DGROUP + extrn page0:byte, page4:byte, page5:byte, page6:byte + extrn page7:byte, page8:byte + + extrn _top:word, _paras:word,first_pa:word,first_dos:word + +Emm_Handle dw 0 ;; Handle returned by EMM +PageFrame dw 0 ;; Segment address for EMM Mapping + +EmmAvail db 0 ;; Emm available + public FirstEmmPage +FirstEmmPage db 0 ;; First page number of Expanded Memory + public EmmPageNum,EmmPage,CodeIn +EmmPageNum db 2 ;; Emm Physical page number to map +EmmPage equ $ +EmmPage0 db 0 ;; Table to map Emm Physical page +EmmPage1 db 0 ;; to actual pagetable offset +EmmPage2 db 0 +CodeIn db 0 ;; Code block currently mapped + public GC_ING +GC_ING dw 0 + +EmmDeviceName db "EMMXXXX0" +m_ems_er db "[VM FATAL ERROR] Expanded Memory Manager error " + db 38h +p_errnum db 30h + db 0Ah,0 + +data ends + + +prog segment byte public 'PROG' + assume cs:PGROUP + public _MMU,_%MMU + public _%MMU0,_%MMU1,_MMUCB + public gcclean + public getbase + public InitMem + public rlsexp + + extrn print_an:near ;; print_and_exit (truncated to 8 chars) + +;;====================================================================== +;; +;; _MMU - Take page passed on stack, and return its paragraph address +;; on the stack. If page in conventional memory, just get its +;; paragraph address from pagetabl. If in expanded memory and +;; already mapped in, return the PageFrame, otherwise request +;; the EMM to map the page into the PageFrame. +;; +;; NOTE: If an expanded memory page is requested which is greater +;; than the normal page size, Emm Pages 0 and 1 are loaded +;; automatically and address of page 0 returned. +;; +;;====================================================================== + +;************************************************************************** +; * +; W A R N I N G * +; Any references to data normally addressed by the data segment register * +; should be prefixed with SS: (segment override) because the DS register * +; may not contain the address of the current data segment. * +; * +;************************************************************************** + + +_MMU proc near ;; Normal Entry from PROG segment + push BP + mov BP,SP ;; Make stack accessable + push BX + mov BX,word ptr [bp+4] ;; BX <= Page number + cmp BL,SS:FirstEmmPage ;; Page in real memory? + jb _MMUPageRet0 ;; Yes..return +_MMU$0: + push AX ;; Save caller's regs + + mov AX,2 ;; DX <= Emm Physical page # + cmp BL,SS:EmmPage2 ;; Mapped in Emm page 2? + je _MMU$00 ;; Yes ...jump + dec AX + cmp BL,SS:EmmPage1 ;; Mapped in Emm page 1? + je _MMU$00 ;; Yes ...jump + dec AX + cmp BL,SS:EmmPage0 ;; Mapped in Emm page 0? + jne _MMU$01 ;; Yes ...jump +_MMU$00: + mov SS:EmmPageNum,AL ;; Mark as last page mapped + jmp _MMUP$10 + +; If large page object, load 2 consecutive pages +_MMU$01: + cmp [SS:psize+BX],MIN_PAGESIZE ;; Normal sized page? + je _MMU$1 ;; Yes...jump + pop AX ;; Restore AX register + mov SS:EmmPageNum,0 ;; Map Page 0 with 1st page + push BX ;; Push Page number + call _MMUPage ;; Go map it + inc SS:EmmPageNum ;; Map Page 1 with 2nd page + add BX,2 ;; Get next page number + push BX ;; Push as argument + call _MMUPage ;; Go map it + pop BX ;; Ignore Para address of 2nd page + pop BX ;; Return Para address of 1st page + jmp _MMUPageRet + + +; Page not currently mapped - Lets map it +_MMU$1: + mov AL,SS:EmmPageNum ;; Last Emm physical page mapped + inc AL ;; Get next + cmp AL,3 ;; + jl _MMU$2 ;; If code block page + xor AL,AL ;; then wrap to zero +_MMU$2: + mov SS:EmmPageNum,AL ;; Update Emm Page last mapped + jmp _MMUP$1 + +_MMU endp + +;;====================================================================== +;; +;; _MMUPage - Load Expanded page number specified in EmmPageNum. +;; Emm Page 3 should only be used for the currently +;; executing code block (via LoadCode macro). +;; +;; NOTE: EmmPageNum must be set before this routine is called. +;; +;;====================================================================== + +_MMUPage proc near + push BP + mov BP,SP + push BX + mov BX,word ptr [bp+4] ;; Get page to map + cmp BL,SS:FirstEmmPage ;; Page in real memory? + jae _MMUP$0 ;; No...go map it + cmp SS:EmmPageNum,3 ;; Loading a code block? + jne _MMUPageRet0 ;; No...return page + mov SS:CodeIn,BL ;; Note code block +_MMUPageRet0: + mov BX,word ptr [BX+SS:pagetabl] +_MMUPageRet: + mov word ptr [bp+4],BX ;; return it + pop BX + pop BP + ret +_MMUP$0: + push AX + xor AH,AH + mov AL,SS:EmmPageNum ;; Get page number to map +_MMUP$1: + xchg AX,BX ;; Note page number in table + mov byte ptr [SS:EmmPage+BX],AL + xchg AX,BX + +;; Map Page from Expanded memory + + push AX ;; Save accross call + push DX + mov AH,EMM_MapPage ;; Map Page Function + sub BL,SS:FirstEmmPage ;; Convert page to map + shr BX,1 ;; to EMM Logical Page + mov DX,SS:Emm_Handle ;; EMM Handle + int EMM_DSR + pop DX ;; Restore saved regs + pop BX + or AH,AH ;; Error doing map page? + jnz Emm_Fatal_Map ;; Yes, fatal + mov AX,BX ;; restore AX +_MMUP$10: + mov BX,SS:PageFrame ;; Get current page frame + shl AL,1 ;; Convert to offset + shl AL,1 + add BH,AL ;; and add to page frame + pop AX + jmp _MMUPageRet + +Emm_Fatal_Map: + jmp Emm_Fatal_Error + +_MMUPage endp + +;;====================================================================== +;; +;; Alternate Entry points +;; +;;====================================================================== + +;; Return Paragraph address of page number + +_%MMU proc far ;; Entry from PROGX segment + push AX + call _MMU + pop AX + ret +_%MMU endp + +;; Load Emm Page 0 - Called from garbage compactor + +_%MMU0 proc far ;; Entry from PROGX segment + push AX + mov SS:EmmPageNum,0 + call _MMUPAGE + pop AX + ret +_%MMU0 endp + +;; Load Emm Page 1 - Called from garbage compactor + +_%MMU1 proc far ;; Entry from PROGX segment + push AX + mov SS:EmmPageNum,1 + call _MMUPAGE + pop AX + ret +_%MMU1 endp + +;; Load Code Block into Emm Page 3 - Entry from PROG segment + +_MMUCB proc near + mov SS:EmmPageNum,3 + jmp _MMUPage + +_MMUCB endp + + +;************************************************************************** +; * +; W A R N I N G * +; Any above references to data normally addressed by the data segment * +; register should be prefixed with SS: (segment override) because the * +; DS register may not contain the address of the current data segment. * +; * +;************************************************************************** + + +;;====================================================================== +;; +;; Get page base address without forcing a page fault. +;; For debugging purposes only (SDUMP.C).... +;; +;; On exit, carry set if page is swapped out, else it's clear (used by XLI). +;; +;;====================================================================== + +getbase proc near + push BP + mov BP,SP + push BX + mov BX,word ptr [BP+4] + cmp BL,SS:FirstEmmPage + jae gc_00 + mov AX,word ptr [BX+SS:pagetabl] ;; Get paragraph address + clc + jmp gb_quit +gc_00: + mov AX,2 + cmp BL,SS:EmmPage0 + je gb_5 + dec AX + cmp BL,SS:EmmPage1 + je gb_5 + dec AX + cmp BL,SS:EmmPage2 + je gb_5 + dec AX + cmp BL,SS:CodeIn + stc + jne gb_quit + mov AX,3 +gb_5: + shl AL,1 + shl AL,1 + or AL,byte ptr [SS:PageFrame+1] + xchg AL,AH + clc +gb_quit: + pop BX + pop BP + ret + +getbase endp + +;;====================================================================== +;; +;; exppage() +;; This routine returns the first emm page number +;; +;;====================================================================== + public exppage +exppage proc near + xor AH,AH + mov AL,FirstEmmPage + shr AL,1 + ret +exppage endp + +;;====================================================================== +;; +;; gcclean() +;; This routine must be called after garbage collection and +;; compaction to clean up the pagetabl and EmmPage table. +;; +;;====================================================================== +gcclean proc near + mov byte ptr EmmPageNum,0 ;; Reset EmmPage indicator + mov word ptr EmmPage,0 + mov byte ptr EmmPage2,0 + ret +gcclean endp + +;;====================================================================== +;; +;; InitMem() +;; Check to see if expanded memory manager is present and set up +;; the memory tables. Return the total number of pages (excluding +;; the dedicated ones) we've been able to allocate. +;; +;;====================================================================== +Lcl_DS_Save dw data ;; Local copy of data segment + +InitMem proc near + mov BX,DS + mov CS:Lcl_DS_Save,DS ;; Save DS for manager above + mov ES,BX ;; Ensure ES = DS + +;; Convert offset within pagetabl[0] into paragraph address + + mov DI,offset pagetabl + mov AX,word ptr [DI] + mov CX,4 + shr AX,CL + add AX,BX + mov word ptr [DI],AX + +;; Same for pagetabl[4] through pagetabl[8] + + mov DX,5 + mov DI,offset pagetabl[8] +EmmP$0: + mov AX,word ptr [DI] + shr AX,CL + add AX,BX + mov word ptr [DI],AX + add DI,2 + dec DX + jnz EmmP$0 + +;; Compute first page paragraph address +;; (In the process, allocate all the memory that DOS will give us.) + + mov BX,0FFFFh ;; first ask for too much + mov AH,048h + int DOS ;; DOS gets an error, but tells us + ;; in BX how much we CAN get + mov AH,048h + int DOS ;; reissue allocation request + mov first_dos,AX ;; save address for returning it to DOS + add AX,(MIN_PAGESIZE shr 4) - 1 ;; Move to page boundary + and AX,not ((MIN_PAGESIZE shr 4) - 1) + mov first_pa,AX ;; first page paragraph address + +;; Initialize page management table with pages available in real memory + + mov DX,nextpage + mov freepage,DX ;; freepage = nextpage + mov DI,_paras ;; Get maximum number of paragraphs + sub DI,(MIN_PAGESIZE shr 4) ;; Get address of last paragraph + xor CX,CX ;; Keep number of pages in CX +EmmP$1: + cmp DI,AX ;; Did we reach it + jb EmmP$2 ;; Yes...no more + cmp DX,NUMPAGES ;; See if we have filled the table + jae EmmP$2 + mov BX,DX + shl BX,1 + mov word ptr [BX+pagetabl],AX + and word ptr [BX+attrib],not NOMEMORY + inc DX + mov word ptr [BX+pagelink],DX + mov word ptr [BX+nextcell],0 + inc CX ;; page_count++ + add AX,(MIN_PAGESIZE shr 4) + jmp EmmP$1 +EmmP$2: + push CX ;; Save # real memory pages + shl DX,1 + mov FirstEmmPage,DL ;; Save first exp mem page number + + mov AH,35H ;; Get Interrupt Vector + mov AL,67H ;; "Vector" + int 21H + mov DI,000AH ;; ES:DI points to device name field + lea SI,EmmDeviceName ;; DS:SI points to device name + mov CX,8 + cld + repe CMPSB ;; Compare the two strings + je EmmPres ;; Jump if EMM present + mov ES,CS:Lcl_DS_Save ;; Restore ES + xor BX,BX ;; No EMM pages available + jmp EmmP$2A ;; Skip talking to Emm Manager +EmmPres: + mov ES,CS:Lcl_DS_Save ;; Restore ES + mov AH,EMM_FrameAddr ;; Get Page Frame Address + int EMM_DSR + or AH,AH + jnz Emm_Fatal_Error +EmmP$: + mov PageFrame,BX ;; Save page frame address + + mov AH,EMM_PageCount ;; Get Unallocated Pages Count + int EMM_DSR ;; (returned in BX) + or AH,AH + jnz EMM_Fatal_Error +EmmP$2A: + cmp BX,0 ;; Are there any pages available? + je EmmP$2B ;; No, jump + mov EmmAvail,1 ;; Yes, note pages available +EmmP$2B: + mov AX,BX ;; Number exp mem pages available + xor DX,DX + mov DL,FirstEmmPage ;; Restore first exp mem page + shr DX,1 ;; Convert to number + xor CX,CX ;; Page count + +;; Why was this here? mov SI,PageFrame + +EmmP$3: + cmp CX,AX ;; Last expanded memory page? + je EmmP$4 ;; Yes...no more + cmp DX,NUMPAGES ;; Filled the table? + jae EmmP$4 ;; Yes...no more + mov BX,DX + shl BX,1 + mov word ptr [BX+pagetabl],0 + and word ptr [BX+attrib],not NOMEMORY + inc DX + mov word ptr [BX+pagelink],DX + mov word ptr [BX+nextcell],0 + inc CX + jmp EmmP$3 + +EmmP$4: + mov nextpage,DX ;; nextpage = lastpage + mov lastpage,DX ;; + jcxz EmmP$Ret ;; Return if no pages allocated + + mov AH,EMM_Allocate ;; Allocate Pages + mov BX,CX ;; Number of pages + int EMM_DSR + or AH,AH + jnz Emm_Fatal_Error + mov emm_handle,DX ;; Save Handle returned +EmmP$Ret: + mov AX,CX ;; Get extended memory count + pop CX ;; Retrieve real memory count + add AX,CX ;; and return combination + ret + +Emm_Fatal_Error: + mov BX,DS ;; Lattice needs ES=DS + mov ES,BX + and AH,0Fh ;; isolate low order nibble of error + add AH,'0' ;; convert to ascii + cmp AH,'9' ;; is it 0-9? + jbe Emm_Fat01 ;; yes, jump + add AH,'A'-'9'-1 ;; add fudge factor for A-F +Emm_Fat01: + mov byte ptr ss:p_errnum,AH ;; Set error indicator + lea BX,ss:m_ems_er ;; Fatal Error Message + push BX + C_call print_an + + +InitMem endp + + +;;====================================================================== +;; +;; rlsexp - Release Expanded Memory Pages +;; +;;====================================================================== +rlsexp proc near + cmp EmmAvail,0 ;; Emm being used? + je rlsret ;; No, Return + mov AH,EMM_Dealloc ;; Yes, Deallocate pages + mov DX,EMM_Handle + int EMM_DSR +rlsret: + ret +rlsexp endp + +prog ends + + end + \ No newline at end of file diff --git a/extsmmu.asm b/extsmmu.asm new file mode 100644 index 0000000..4dd8737 --- /dev/null +++ b/extsmmu.asm @@ -0,0 +1,607 @@ + name SMMU + title Scheme Memory Management Utilities + page 62,132 +; =====> SMMU.ASM +;**************************************************************** +;* TIPC Scheme '84 Memory Management Utilities * +;* * +;* (C) Copyright 1985, 1987 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Author: Herman Schuurman * +;* Date written: 26 August 1985 * +;* Last change: 17 September 1985 * +;* History: * +;* rb 4/ 5/87 "getbase" returns in carry flag a page's * +;* swap state * +;**************************************************************** + .286c ;; Utilize the expanded 80286 instruction set + include pcmake.equ + include schemed.equ + include schemed.ref + include schemed.mac + +DOS equ 021h +ExtAlloc equ 99 ;; # extended mem pages to allocate initially + ;; (99 effectively removes barrier) + +DGROUP group data +PGROUP group prog + +data segment word public 'DATA' + assume ds:DGROUP + extrn page0:byte, page4:byte, page5:byte, page6:byte + extrn page7:byte, page8:byte + + extrn _top:word, _paras:word,first_pa:word,first_dos:word + +;; Age table + +agetable label word + dw NUMPAGES dup (0) + +AllocPag dw 0 ;; Allocated number of pages +;; +;; The following EQUates give the special bits within the page table, +;; mainly used for the CLOCK algorithm. Note that these equates are +;; also defined in SBIGEXT.C if modified. + +SWAPPED equ 00000001b ;; Page is currently in extended memory +FIXED equ 10000000b ;; Fixed in memory (long pages) + +PageBuf dw SWAPPED ;; Current available swap page (default 0) + + public VMCycle +VMCycle dw 0 ;; Current VM cycle (modulo 65536) + +;; public FAULTS +;;FAULTS dw 0 ;; Number of page faults + + public GC_ING +GC_ING dw 0 ;; Indicate whether garbage collecting + +m_lck_er db "[VM FATAL ERROR] Memory lock error - no page to swap",0Ah,0 +m_pag_er db "[VM FATAL ERROR] Memory paging error number " +p_errnum db 30h + db 0Ah,0 + +;; Extended memory support structures.... + +DESC struc ;; Data segment descriptor +DESCLimit dw MIN_PAGESIZE ;; Segment limit (length) +DESCBaseL db 0 ;; Physical address - bits 7..0 +DESCBaseM dw 0 ;; Physical address - bits 23..8 + db 0 ;; Access rights byte + dw 0 ;; Intel reserved.... +DESC ends + +;;====================================================================== +;; +;; The GDT passed to INT 15h function 87h, is organized as follows : +;; +;; .-----------. +;; V | +;; [ES:SI] --> +00 .---------------. | +;; | Dummy | | +;; +08 |---------------| | +;; | GDT Loc |---' +;; +10 |---------------| +;; | Source GDT | +;; +18 |---------------| +;; | Target GDT | +;; +20 |---------------| +;; | BIOS code seg | +;; +28 |---------------| +;; | Stack segment | +;; `---------------' +;; +;;====================================================================== + +GDT label byte ;; Begin of global descriptor table + DESC <> ;; Dummy descriptor + + DESC <> ;; GDT descriptor + +Source DESC <,,,93h,> ;; Source area descriptor + +Target DESC <,,,93h,> ;; Target area descriptor + + DESC <> ;; BIOS code segment descriptor + + DESC <> ;; Stack segment descriptor + +data ends + +prog segment byte public 'PROG' + assume cs:PGROUP + public _MMU,_%MMU +;; The following are here so link edit won't find urevolved refs + public _%MMU0,_%MMU1,_MMUCB + public getbase + public InitMem + + extrn print_an:near ;; print_and_exit (truncated to 8 chars) + +;;====================================================================== +;; +;; _MMU - Get page indicated on stack into real memory, +;; and return the paragraph address of it on the stack... +;; +;;====================================================================== +Lcl_DS_Save dw data ;; Saved Data Segment + +_%MMU proc far ;; Entry from PROGX segment +_%MMU0: +_%MMU1: + push AX + call _MMU + pop AX + ret +_%MMU endp + +_MMU proc near ;; Normal Entry from PROG segment +_MMUCB: + push BP ;; Make stack accessable + mov BP,SP + push DS ;; Save Caller's DS + mov DS,CS:Lcl_DS_Save ;; and make our's available + push AX + push BX + mov BX,word ptr [bp+4] ;; Get pagetabl offset + mov AX,word ptr pagetabl+[BX] ;; Get (new) table indicator + cmp BX,PreAlloc*2 ;; If one of dedicated pages + jb M_RetPage ;; then jump + test byte ptr [pagetabl+BX],SWAPPED ;; If in extended memory + jne M_Swap ;; then go swap it in + +;; Update age and return para address + +M_Ret: + inc VMCycle ;; Time stamp + jnz M_Ret01 ;; On overflow + call PgSweep ;; Go sweep entire pagetabl +M_Ret01: + mov AX,VMCycle ;; Get time stamp + mov word ptr agetable+[BX],AX ;; Place in ageing table + + mov AX,word ptr pagetabl+[BX] ;; Get paragraph address + xor AL,AL +M_RetPage: + mov word ptr [BP+4],AX ;; Set return value + pop BX + pop AX + pop DS + pop BP + ret + +;; Retrieve page from extended memory + +M_Swap: + pusha ;; Save all registers + push ES ;; including ES + push AX ;; Save page number on stack + push BX ;; Save the page table entry + call FndPage ;; Find a page for swapping + pop DI ;; Retrieve final destination + mov AX,PageBuf ;; Set swapped page address + xchg pagetabl+[BX],AX ;; Get the current page contents + xor AL,AL ;; Remove attribute bits + mov pagetabl+[DI],AX + mov BX,PageBuf ;; Get the page buffer address + shr BX,2 ;; Adjust the page base address + add BH,10h ;; and raise above 1MByte + shr AX,4 ;; Create a correct address + push AX ;; Save source as next destination + call MovePage ;; Swap old page out + pop BX ;; Set next destination + pop AX ;; and old source + mov PageBuf,AX ;; Set new swap page + shr AX,2 + add AH,10h + call MovePage ;; Swap new page in + pop ES ;; Restore all registers + popa ;; including ES + +;; inc FAULTS ;; update page fault count + + jmp M_Ret + +_MMU endp + +;;====================================================================== +;; +;; PgSweep - page table clocked sweep routine. +;; This routine cleans up the current page table after a full +;; reference cycle (253 counts). +;; +;;====================================================================== + + public PgSweep +PgSweep proc near + push AX + push BX + push CX + mov BX,offset agetable[PreAlloc*2] ;; Don't bother with the + mov CX,AllocPag ;; dedicated pages in the table + xor AX,AX ;; Clear AX register +PgSwp$0: + mov AL,byte ptr [BX+1] ;; Get the current high byte + mov word ptr [BX],AX + add BX,2 + loop PgSwp$0 ;; Continue with next sweep + mov VMCycle,100h ;; Set next cycle + pop CX + pop BX + pop AX + ret + +PgSweep endp + +;;====================================================================== +;; +;; FndPage - Find a swappable page in the page table. +;; This routine scans the page table (non-dedicated pages only), +;; for swappable pages. The least recently used page NOT USED +;; IN THE CURRENT VM INSTRUCTION is selected... +;; +;; As an added bonus, the current code page can not be swapped +;; either..... +;; +;;====================================================================== + +FndPage proc near + mov BX,cb_pag ;; Get entry into current code page + cmp BX,PreAlloc*2 ;; Check against permanent pages + jb FndPag$1 ;; Don't worry...it'll stay around + cmp pagetabl+[BX],FIXED ;; Check for fixed page + jbe FndPag$1 ;; which will stay too + mov AX,VMCycle ;; Set to current cycle + mov agetable+[BX],AX ;; Try to keep page in memory +FndPag$1: + mov BX,PreAlloc*2 ;; Don't bother with the + mov CX,AllocPag ;; dedicated pages in the table + xor DX,DX ;; Set initial distance + +FndPag$2: + test byte ptr [BX+pagetabl],FIXED+SWAPPED + jne FndPag$3 ;; Fixed,Swapped,Noswap pages are exempt + mov AX,VMCycle ;; Check against current cycle + sub AX,agetable+[BX] + cmp DX,AX + jae FndPag$3 ;; Already found a better page + mov SI,BX ;; Save the page address + mov DX,AX ;; and its value +FndPag$3: + add BX,2 + loop FndPag$2 ;; Continue with next sweep + +;; Completed the sweep..the most desirable page should +;; be in SI now, unless DX is still 0.... + + cmp DX,0 ;; See if we found a page + je FndPag$4 ;; No...error + mov BX,SI ;; Return its number + ret + + public FndPag$4 + +FndPag$4: + lea BX,m_lck_er ;; Indicate a lock error +FatalError: + push BX ;; Save the error message + mov AX,DS + mov ES,AX ;; Make sure ES is Ok... + C_call print_an ;; Print the message and quit + +FndPage endp + +;;====================================================================== +;; +;; Get page base address without forcing a page fault. +;; For debugging purposes only (SDUMP.C).... +;; +;; On exit, set carry if page is swapped out, else clear carry (used by XLI) +;; +;;====================================================================== + +getbase proc near + push BP + mov BP,SP + mov BX,word ptr [BP+4] + mov AX,word ptr [BX+pagetabl] ;; Get table indicator + + test AX,SWAPPED ; is page swapped out? + jz getb_10 ; no, jump + stc ; page is swapped out, set carry + jmp short getb_20 +getb_10: clc ; page is in memory, clear carry + +getb_20: pop BP + ret + +getbase endp + +;;====================================================================== +;; +;; Swap page to extended memory +;; Used in FIND_BIG_BLOCK in SBIGMEM.C +;; +;;====================================================================== + + public move_pag +move_pag proc near + push BP + mov BP,SP + pusha ;; Save all registers + push ES ;; including ES + + mov DI,[BP+6] ;; Extended memory page to swap + mov AX,word ptr pagetabl+[DI] ;; AX <= Extended memory address + + mov BX,[BP+4] ;; Real memory page to swap + xchg pagetabl+[BX],AX ;; Update its pagetabl entry + xor AL,AL ;; AX <= para address of page to swap + push DI + push AX + + mov BX,word ptr [BX+pagetabl] ;; Extended page address (destination) + shr BX,2 ;; Adjust page base address + add BH,10h ;; and raise above 1mb address + shr AX,4 ;; Real page address (source) + call MovePage ;; Move it + + pop AX ;; Reload paragraph address + or AL,FIXED ;; Fixed attribute + pop DI ;; Reload page number + mov word ptr pagetabl+[DI],AX ;; Update pagetabl entry + + pop ES ;; Restore all regs + popa ;; including ES + + pop BP ;; restore base ptr + ret + +move_pag endp + + subttl Extended memory support + page +;;====================================================================== +;; +;; Extended memory I/O routine +;; +;; Source address is in AX, destination in BX. +;; The high byte of each register contains the upper 8 bits of +;; the real address (bits 16..23). The low byte contains the +;; next 8 bits of the real address (bits 8..15)... +;; +;;====================================================================== + +MovePage proc near + mov SI,SS + mov CX,SP ; Save the original stack in SI:CX + cli + mov DX,CS + mov SS,DX + mov SP,offset PGROUP:ExtMemStack + sti + push SI + push CX ; Save old stack info + mov Source.DESCBaseM,AX + mov Target.DESCBaseM,BX + mov CX,MIN_PAGESIZE/2 ;; Reduce pagesize to word count + push DS + pop ES + mov SI,offset DGROUP:GDT + mov AH,87h ; Perform a block move + int 15h + + ; kludge to fix hanging keyboard + mov AL,0AEh ; ensure keyboard enabled + out 64h,AL ; output to 8042 controller + + pop CX + pop BX + cli + mov ss,BX ; Restore the original stack + mov sp,CX + sti + jz MovRet ; If successful, return + or AH,AH ; Return status non-zero? + jnz MovePage$1 ; Yes...error +MovRet: + ret + +;; Error detected durin paging ....as fatal as can be.... + +MovePage$1: + or p_errnum,AH ; Set error indicator + lea BX,m_pag_er ; Load up Error message + jmp FatalError ; Abort + +MovePage endp + + +;;====================================================================== +;; +;; InitMem() +;; Initialize all the memory tables correctly. Return the +;; total number of pages (excluding the dedicated ones) we've +;; been able to allocate. +;; +;;====================================================================== + +InitMem proc near + mov BX,DS + mov CS:Lcl_DS_Save,BX ;; Save DS for manager above + mov ES,BX ;; Ensure ES = DS + +;; Convert offset within pagetabl[0] into paragraph address + + mov DI,offset pagetabl + mov AX,word ptr [DI] + mov CX,4 + shr AX,CL + add AX,BX + mov word ptr [DI],AX + +;; Same for pagetabl[4] through pagetabl[8] + + mov DX,5 + mov DI,offset pagetabl[8] +EmmP$0: + mov AX,word ptr [DI] + shr AX,CL + add AX,BX + mov word ptr [DI],AX + add DI,2 + dec DX + jnz EmmP$0 + +;; Compute first page paragraph address +;; (In the process, allocate all the memory that DOS will give us.) + + mov BX,0FFFFh ;; first ask for too much + mov AH,048h + int DOS ;; DOS gets an error, but tells us + ;; in BX how much we CAN get + mov AH,048h + int DOS ;; reissue allocation request + mov first_dos,AX ;; save address for returning it to DOS + add AX,(MIN_PAGESIZE shr 4) - 1 ;; Move to page boundary + and AX,not ((MIN_PAGESIZE shr 4) - 1) + mov first_pa,AX ;; first page paragraph address + + +;; Initialize page management table with pages available in real memory + + mov DX,nextpage + mov freepage,DX ;; freepage = nextpage + mov DI,_paras ;; Get maximum number of paragraphs + sub DI,(MIN_PAGESIZE shr 4) ;; Get address of last paragraph + xor CX,CX ;; Keep number of pages in CX +InitM$1: + cmp DI,AX ;; Did we reach it + jb InitM$2 ;; Yes...no more + cmp DX,NUMPAGES ;; See if we have filled the table + jae InitM$2 + mov BX,DX + shl BX,1 + mov word ptr [BX+pagetabl],AX + and word ptr [BX+attrib],not NOMEMORY + inc DX + mov word ptr [BX+pagelink],DX + mov word ptr [BX+nextcell],0 + inc CX ;; page_count++ + add AX,(MIN_PAGESIZE shr 4) + jmp InitM$1 + +;; +;; At this time, DX <= next avail page number, CX <= current page count +;; +;; Now Lets see if this is a 286 machine +;; + +InitM$2: + mov nextpage,DX ;; Save next available page + xor AX,AX + + mov BX,PC_MAKE ;; Get pc type + cmp BX,1 ;; Is it TIPC? + jne InitM$20 ;; No, go check for 286/386 + push DS ;; Yes,lets check for a Bus Pro + mov DS,AX ;; DS <= 0 for addressing low mem + mov BX,DS:word ptr [01A2h] ;; Checkout vector 68 bytes 2 & 3 + pop DS + add BL,BH + cmp BL,0F0h ;; If AL==F0 then TIPC=Business Pro + je InitM$21 + jne InitM$Ret +InitM$20: + cmp BX,IBMAT ;; Is it IBM AT? + ;; (includes XT/286, PS/2-50,-60) + je InitM$21 ;; yes, jump + cmp BX,IBM80 ;; Is it IBM PS/2 Model 80? + jne InitM$Ret ;; no, jump + +;; Fill out rest of page table with extended memory pages. Only allocate +;; the first 512kb of extended memory; the rest is allocated but marked +;; marked as unallocated in the page tables (ie, ATTRIB and PAGELINK). This +;; will force the memory allocation to work (at least initially) in real +;; memory and the first 512k of extended memory until an "out of memory". +;; At that time, NEXTPAGE will be updated, and some more pages in extended +;; memory will then be marked as allocated (ie, ATTRIB and PAGELINK). This +;; scenario will be repeated until all of extended memory is actually used. +;; The upper limit will be help in LASTPAGE. Also see out_of_memory in +;; SMEMORY.C +;; +;; This should help performance for those applications which generate a +;; lot of garbage, but don't have to use the full extent of the extended +;; memory. + +InitM$21: + push CX ;; Save current count + mov AH,88h ;; Get number of contiguous 1k + int 15h ;; blocks starting at 1MByte + add ax,((MIN_PAGESIZE shr 10) - 1) + and ax,not ((MIN_PAGESIZE shr 10) - 1) + xor DX,DX + mov CX,(MIN_PAGESIZE shr 10);; Number 1K blocks per page + idiv CX ;; Reduce to # of pages + mov DX,nextpage ;; Retrieve next available page number + mov CX,0101h ;; Count the extended pages + xor DI,DI +InitM$3: + dec AX ;; Check for last extended memory page + jle InitM$4 ;; Yes...no more + cmp DX,NUMPAGES ;; See if we have filled the table + jae InitM$4 + mov BX,DX ;; DX = page number + shl BX,1 ;; BX = page table offset + inc DX ;; DX = next page number + mov word ptr [BX+pagetabl],CX ;; Page's address + mov word ptr [BX+nextcell],0 ;; Nextcell in page = 0 + cmp CH,ExtAlloc ;; 512kb allocated? + jb InitM$33 ;; below, mark as allocated + ja InitM$35 ;; above, skip allocation + mov DI,DX ;; equal, EXT MEM LIMIT +InitM$33: + and word ptr [BX+attrib],not NOMEMORY + mov word ptr [BX+pagelink],DX ;; No, update pagelink info +InitM$35: + inc CH ;; Next extended memory page + jmp InitM$3 ;; Go allocate next page + +;; At this time, DX <= last page number, CH <= # extended memory pages + + +InitM$4: + mov lastpage,DX ; last page number + mov nextpage,DX ; default nextpage to lastpage + or DI,DI ; Did we get our extended mem limit? + jz InitM$45 ; no, lastpage=nextpage, jump + mov nextpage,DI ; yes, lets use that limit +InitM$45: + xor AH,AH + mov AL,CH ; Get extended memory count + dec AX ; Don't count the swapping page + pop CX ; Retrieve real memory count +InitM$Ret: + add AX,CX ; Total Page count + mov AllocPag,AX ; Save allocated pages for later + ret + +InitMem endp + +;;====================================================================== +;; +;; Temporary stack during extended memory operations... +;; +;;====================================================================== + + db 10 dup ("ExtStack") +ExtMemStack label word ;; Extended memory support stack + +prog ends + + end + \ No newline at end of file diff --git a/flo2hex.asm b/flo2hex.asm new file mode 100644 index 0000000..a110f73 --- /dev/null +++ b/flo2hex.asm @@ -0,0 +1,106 @@ + name flo2hex + title Convert Floating Point Number to Hex Ascii + page 62,132 +; =====> FLO2HEX.ASM +;**************************************************************** +;* TIPC Scheme Runtime Support * +;* * +;* (C) Copyright 1987 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Author: Terry Caudill * +;* Date written: 10 March 1987 * +;**************************************************************** + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +hexbuf db 030h,031h,032h,033h,034h,035h,036h,037h,038h,039h + db 041h,042h,043h,044h,045h,046h +data ends + +XGROUP group PROGX +PROGX segment byte public 'PROGX' + assume CS:XGROUP,DS:DGROUP + +;************************************************************************ +;* * +;* Routine Name: FLO2HEX * +;* * +;* Description: FLO2HEX is a %escape routine provided for PC+ and * +;* is used to return the Hex Ascii value of a floating * +;* point number when outputting kb's in fsl format. * +;* * +;* Calling Sequence: (FLO2HEX float string #words) * +;* where: float = the floating point number * +;* string = a return string to place result * +;* #words = size of the float to be converted * +;* will be 4 for floating point * +;* * +;* Note: Actually, this routine can be called with integers, etc. * +;* * +;************************************************************************ + +INARGS struc +OLDBP DW ? +FRETN DD ? ; Far return to 'prog' segment +NRETN DW ? ; Return from flo2hex +_STRING DW ? +_FLOAT DW ? +_WORDS DW ? +INARGS ENDS + +%flo2hex proc far + push BP + mov BP,SP + mov si,[bp]._FLOAT ; floating point value + mov di,[bp]._STRING ; string for result + mov dx,[bp]._WORDS ; #words to convert + mov bx,offset hexbuf + mov cl,4 ; shift count + cld +movdigits: + lodsw ; get word to convert + push ax ; save word + shr ax,cl ; work on high byte + shr ax,cl + call cvthex ; convert lower byte + stosw ; store into string + pop ax ; restore word + xor ah,ah ; now work lower byte + call cvthex ; convert it + stosw ; store into string + dec dx ; any more words? + jne movdigits ; yes, jump + + xor al,al ; 0 terminate the string + stosb + + mov ax,[bp]._STRING ; return string + pop BP + ret ; return to caller. +%flo2hex endp + +cvthex proc near + shl ax,cl ; seperate digits + shr al,cl ; work on lower nibble + xlat ; convert to hex + xchg ah,al ; work on upper nibble + xlat ; convert to hex + ret ; return with hex ascii value +cvthex endp +PROGX ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + public flo2hex + +flo2hex proc near + call %flo2hex + ret +flo2hex endp +prog ends + end + \ No newline at end of file diff --git a/get_path.asm b/get_path.asm new file mode 100644 index 0000000..5f3cade --- /dev/null +++ b/get_path.asm @@ -0,0 +1,205 @@ +; =====> GET_PATH.ASM +;*************************************** +;* TIPC Scheme Runtime Support * +;* Get PATH= String From Environment * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 8 July 1985 * +;* Last Modification: 6 November 1985 * +;*************************************** + include scheme.equ + +DGROUP group data +XGROUP group PROGX +PGROUP group prog + +MSDOS equ 021h + +data segment word public 'DATA' + assume DS:DGROUP + extrn _psp:dword +path_ db "PATH=" +path_1 equ $ +ret_sav1 dw 0 ; return address save area +ret_sav2 dw 0 ; return address save area +data ends + +prog segment byte public 'PROG' + assume CS:PGROUP +;************************************************************************ +;* Far Linkage to "getmem" Routine * +;************************************************************************ +%getmem proc far + pop ret_sav1 ; save far return address + pop ret_sav2 + push DS ; update ES to point to the current + pop ES ; data segment + extrn getmem:near + call getmem ; allocate memory + push ret_sav2 ; push the far return address back + push ret_sav1 ; on the TIPC's stack + ret ; return +%getmem endp +prog ends + +PROGX segment byte public 'PROGX' + assume CS:XGROUP +;************************************************************************ +;* Get PATH= String From Environment * +;************************************************************************ +get_args struc +get_base dw ? ; paragraph address of environment +get_strt dw ? ; starting offset of string +get_len dw ? ; length of PATH= string + 1 +str_end dw ? ; ending offset of directory pathname +indx_sav dw ? ; PATH= index save area +buffer db 128 dup (?) ; local character buffer +get_BP dw ? ; caller's BP register + dw ? ; callle's DS register + dw ? ; caller's ES register + dd ? ; return address (far call) + dw ? ; return address (near call) +filespec dw ? ; file specification (ASCIZ string pointer) +get_args ends + +%getpath proc far + push ES ; save the caller's ES register + push DS ; save the caller's DS register + push BP ; save the caller's BP register + sub SP,offset get_BP ; allocate local storage + mov BP,SP ; establish local addressability + +; Test to see if file is in the default directory + mov DX,[BP].filespec ; load pointer to the filespec + xor CX,CX ; zero the search attributes + mov AH,04Eh ; load the function code (Find File) + int MSDOS ; service call + jc not_curr ; if not in default directory, jump + mov AH,19h ; else get current pathname + int MSDOS ; Get current disk drive + inc AL ; adjust for further calls + mov AH,AL ; make an upper case letter out of it + add AH,40h ; 40h => '@', 41h => 'A', etc + mov byte ptr [BP].buffer,AH ; Put drive letter into pathname + mov byte ptr [BP].buffer+1,':' + mov byte ptr [BP].buffer+2,'\' + lea SI,[BP].buffer+3 ; offset just below E:\ or similar + mov DL,AL ; drive letter + mov AH,47h ; Get current directory path + int MSDOS + mov DI,SI ; SI shouldn't have changed + mov CX,64 ; max length of pathname + xor AL,AL ; search for a NUL char + repne scasb ; Find end of string DS:[DI] + mov [BP].str_end,DI ; copy offset of end of pathname + jmp foundit ; return directory name to caller in a string + +; Load a pointer to the current environment (offset 02C in PSP) +not_curr: mov ES,word ptr _psp+2 + mov ES,ES:02Ch + mov [BP].get_base,ES ; save paragraph address of environment + xor DI,DI ; initialize environment offset to zero + +; Test for end of environment +get_plop: cmp byte ptr ES:[DI],0 ; last entry in environment? + je error ; if so, PATH= not found + mov SI,offset path_ ; load address of comparison string + mov CX,path_1-path_ ; and length of same +repe cmps path_,ES:[DI] ; does this entry begin "PATH="? + je found ; if so, found it! (jump) + xor AX,AX ; clear AX for search + mov CX,-1 ; set CX for maximum length +repne scas byte ptr ES:[DI] ; find \0 which terminates string + jmp get_plop ; loop + +; PATH= found!-- begin searching its directories +found: mov SI,DI ; copy address of PATH= string +next_one: lea DI,[BP].buffer ; load address of output buffer + mov DX,DS ; save current DS value in DX + mov ES,DX ; ES <- current data segment + mov DS,[BP].get_base ; DS <- environment object base + lodsb ; load 1st char from path directory string + cmp AL,0 ; end of PATH list? + je error ; if so we didn't find filespec in path +here: cmp AL,';' ; semicolon? + je end_semi ; if semicolon, jump + cmp AL,0 ; zero? (superfluous test 1st time in loop) + je end_0 ; if zero, jump + stosb ; store character into output buffer + lodsb ; load next char from PATH string + jmp short here ; loop 'til end of string + +; Error-- PATH= not found, getmem failed, or filespec not found +error: xor AX,AX ; prepare to return a null pointer + jmp short get_ret ; return + +; Directory path copied-- append filespec to directory pathname +end_0: dec SI ; back up pointer for end of string condition +end_semi: mov [BP].str_end,DI ; save ending offset of directory pathname + mov DS,DX ; reset DS to point to data segment + mov AL,'\' + cmp AL,[DI]-1 + je b_slash + stosb +b_slash: mov [BP].indx_sav,SI ; save pointer to next character in PATH= + mov SI,[BP].filespec ; load address of input filespec +fs_loop: lodsb ; load next character in filespec + stosb ; and move it to the output buffer + cmp AL,0 ; end of string? + jne fs_loop ; if not end of string, loop (jump) + +; Search directory for file + lea DX,[BP].buffer ; load address of the complete file + mov AH,04Eh ; load function code + int MSDOS ; search for the file + jnc foundit ; if file found, jump + +; File not found-- search next directory + mov SI,[BP].indx_sav ; load offset of next character in PATH= + jmp next_one ; search next directory + +; File found in this directory-- return directory name in string +foundit: mov DI,[BP].str_end ; load ending offset of directory path + xor AX,AX ; put a zero end-of-string terminator + stosb ; at end of directory path + lea BX,[BP].buffer ; load beginning offset of buffer + sub DI,BX ; compute string length + 1 + push DI ; and push as argument to getmem + call %getmem ; allocate a string + cmp AX,0 ; getmem successful? + je error ; if getmem failed, error (jump) + pop CX ; reload string length + mov DX,DS ; ES <- current data segment + mov ES,DX + mov DI,AX ; DI <- address of newly allocated string + lea SI,[BP].buffer ; SI <- address of local buffer +rep movsb ; copy string from local buffer + +; Return to calling program +get_ret: mov SP,BP ; drop arguments off TIPC's stack + add SP,offset get_BP ; deallocate local storage + pop BP ; restore caller's BP + pop DS ; restore caller's DS + pop ES ; restore caller's ES + ret ; return + +%getpath endp +PROGX ends + +prog segment byte public 'PROG' + assume CS:PGROUP +;************************************************************************ +;* Linkage to %getpath * +;************************************************************************ + public get_path +get_path proc near + call %getpath + ret +get_path endp + +prog ends + end + \ No newline at end of file diff --git a/glue.asm b/glue.asm new file mode 100644 index 0000000..bfa522e --- /dev/null +++ b/glue.asm @@ -0,0 +1,32 @@ + page 84,120 + +dgroup group data +pgroup group prog + +data segment word public 'DATA' +data ends + +prog segment byte public 'PROG' + assume cs:pgroup,ds:dgroup + + extrn _psp:word,_tsize:word + extrn xwait:dword,xbye:dword + public xli_wait,xli_bye + +xli_wait proc near + push _psp+2 + push _tsize + call dword ptr [xwait] + pop ax + pop ax + ret +xli_wait endp + +xli_bye proc near + call dword ptr [xbye] +xli_bye endp + +prog ends + end + + \ No newline at end of file diff --git a/graphcmd.asm b/graphcmd.asm new file mode 100644 index 0000000..c65286d --- /dev/null +++ b/graphcmd.asm @@ -0,0 +1,1992 @@ + name graphics + title PC Scheme Graphics + page 60,132 +;----------------------------------------------------------------------------- +; +; TITLE: PC Scheme Graphics +; AUTHOR: Medford W. Haddock II (Rusty) +; DATE: October 20, 1983 +; COMPUTER: Texas Instruments Professional Computer with 3-plane graphics +; IBM PC with Color, Enhanced, or Professional Graphics Adapters +; ABSTRACT: These routines are designed to interface between PC Scheme +; and the color graphics board for both the IBM and TI PCs. +; REVISIONS: ds - 9/25/86 - added support for the IBM EGA modes 14 and 16 +; rb 11/7/86 - added point, line, box clipping (both TI and IBM) +; rb 11/24/86 - fix line drawn from p1 to p2 not same as +; line drawn from p2 to p1 +; mrm 4/15/87 - modified set-mode! to run w/o screen flicker +; modified set-palette! to save EGA colors +; rb 6/13/87 - use CR for EGA mode 16 for illegal mode values +; +;----------------------------------------------------------------------------- + + include pcmake.equ + + page +;----------------------------------------------------------------------------- +; The "intersect" macro. in: none +; out: AX=intersect value +; destroys: AX,BX,CX,DX,SI +; usage: intersect L,y2,x2,x1,y1 (be careful of the funny ordering) +; +; Given a line that crosses a clipping edge, determine the point of +; intersection: one of the coordinates is that of the clipping edge, +; and this macro calculates the other coordinate. +; +; The equation pattern is: new-y = y1 + (y2 - y1) * (L - x1) / (x2 - x1). +;----------------------------------------------------------------------------- +intersect macro L,y2,x2,x1,y1 + mov AX,L + mov BX,y2 + mov CX,x2 + mov DX,x1 + mov SI,y1 + sub BX,SI ;; y2 - y1 + sub CX,DX ;; x2 - x1 + sub AX,DX ;; L - x1 + imul BX ;; (y2 - y1) * (L - x1) = q + idiv CX ;; q / (x2 - x1) + add AX,SI ;; y1 + q / (x2 - x1) + endm + +;----------------------------------------------------------------------------- +; The "overlap" macro. in: none +; out: none (look at Z flag) +; destroys AX,BX,CX +; usage: overlap contained,disjoint +; +; Compares the two rectangles: +; (Curr_X,Curr_Y) - (Stop_X,Stop_Y) and +; (Clip_left,Clip-top) - (Clip_right,Clip-bottom) +; and returns status on their intersection. +; +; If the Curr/Stop rectangle is totally contained in the clipping rectangle, +; jump to label "contained" with the Z flag on. If they are disjoint, jump +; to label "disjoint" with the Z flag off. Otherwise, they intersect, so +; fall through. Both jumps are short relative jumps. +;----------------------------------------------------------------------------- +overlap macro contained,disjoint + mov AX,Curr_X + mov BX,Curr_Y + call Encode_XY + mov CH,CL + mov AX,Stop_X + mov BX,Stop_Y + call Encode_XY + cmp CX,0 + jz contained ;;jump if Curr/Stop totally contained in CR + test CH,CL + jnz disjoint ;;jump if they're disjoint + endm + + page +;----------------------------------------------------------------------------- + +TI_CRT equ 49h +IBM_CRT equ 10h +DOS_FUN equ 21h + + page +XGROUP group PROGX +DGROUP group DATA +DATA segment byte public 'DATA' + assume DS:DGROUP + public VID_MODE + extrn PC_MAKE:word + extrn char_hgt:word +;------------------------------------------------------------------------------ +; Some TIPC system constants. +;------------------------------------------------------------------------------ +X_MAX equ 720 ; Horizontal resolution +Y_MAX equ 300 ; Vertical resolution +Num_Colors equ 8 ; Number of colors displayable by TIPC +Bytes_per_Line equ 92 ; (720-displayed + extra word)/ 8-bits/byte +;----------------------------------------------------------------------------- +; These are the default values of the palette & misc. output latches. +;----------------------------------------------------------------------------- +DEF_RED equ 0AAh +DEF_GRN equ 0CCh +DEF_BLU equ 0F0h +TEXT_ON equ 040h ; This value is needed for bit-twiddling +TEXT_OFF equ 00h +YES_GRPH equ 0FFh +NO_GRAPH equ 00h +TRUE equ 0FFh +FALSE equ 00h +;----------------------------------------------------------------------------- +; Local variable storage. +;----------------------------------------------------------------------------- +Curr_X dw ? ; Current x-coordinate +Curr_Y dw ? ; Current y-coordinate +Stop_X dw ? ; Second endpoint x-coordinate for drawing +Stop_Y dw ? ; Second endpoint y-coordinate for drawing +clip_left dw ? ; Clipping rectangle (in screen coordinates) +clip_top dw ? +clip_right dw ? +clip_bottom dw ? +px dw ? ; Points to the independent variable +py dw ? ; Points to the dependent variable +Delta_X dw ? ; = Stop_X - Start_X +Delta_Y dw ? ; = Stop_Y - Start_Y +X_Dir dw ? ; -1,0,+1 : step of independent variable +Y_Dir dw ? ; -1,0,+1 : step of dependent variable +Xend dw ? ; End value of independent variable +Incr1 dw ? ; Step for using pnt below desired value +Incr2 dw ? ; Step for using pnt above desired value +GRAFIX_ON dw YES_GRPH ; TI Graphics are initially enabled +VID_MODE dw 3 ; Current video mode for TI (text & grafx on) +Box_Hite dw ? ; Box is this number of pixels high +Box_Width dw ? ; Number of bytes the box's width occupies +Left_Offset dw ? ; Byte offset into graphx planes of upper left box +Left_End dw ? ; Bit pattern of left end of solid box +Left_Side dw ? ; Bit pattern of left side of hollow box +Right_End dw ? ; Bit pattern of right end of solid box +Right_Side dw ? ; Bit pattern of right side of hollow box +Fill_Fig db ? ; True if box is to be filled +func db ? ; EGA function 0 or 18h +f_code db 7 ; and or xor function +st_word dw ? ; start sceen offset +st_bit dw ? ; start bit offset +ed_word dw ? ; ending word offset +ed_bit dw ? ; ending bit offset +w_p_row dw 40 ; # of words per row +b_p_wrds db 16 ; 16 bits per word +two dw 2 ; two +pix_c dw ? ; pixel color +gra_ram dw 0a000h ; EGA graphics ram address +y_val dw ? + +;----------------------------------------------------------------------------- +; Local constants storage. +;----------------------------------------------------------------------------- +X_Resolution dw X_MAX +Y_Resolution dw Y_MAX +Bits_per_Byte dw 8 +Color_Cycle db 8 +;----------------------------------------------------------------------------- +; Stored here will be the current values for the latches should +; the (ab)user decide to change them later with (set-palette!). +;----------------------------------------------------------------------------- +RED_Latch db DEF_RED +GRN_Latch db DEF_GRN +BLU_Latch db DEF_BLU +;----------------------------------------------------------------------------- +; A table of zeroes for clearing the palettes before a mode change on +; the EGA. +; A table of current values for the EGA colors. The table will be +; modified by each set-palette! command for the EGA. These values +; will be used to restore the colors after a mode change on the EGA. +;----------------------------------------------------------------------------- +clear_pal db 17 dup(0) +save_pal db 0,1,2,3,4,5,6,7,38h,39h,3ah,3bh,3ch,3dh,3eh,3fh,0 +;----------------------------------------------------------------------------- +; These are the segments for the three graphics bit-planes +; in the TIPC color graphics board. The order below is +; important - see XPCINIT +;----------------------------------------------------------------------------- +Bank_A dw 0C000h +Bank_B dw 0C800h +Bank_C dw 0D000h +Misc_Latch dw 0DF82h +;----------------------------------------------------------------------------- +; These are the segments of the Red, Green, Blue palette latches. +;----------------------------------------------------------------------------- +RED_Palette dw 0DF01h +GRN_Palette dw 0DF02h +BLU_Palette dw 0DF03h +;----------------------------------------------------------------------------- +; Color to palette bits translation +;----------------------------------------------------------------------------- +Palette_Trans label byte + db 00000001b + db 00000010b + db 00010000b + db 00100000b + db 00000100b + db 00001000b + db 01000000b + db 10000000b +;----------------------------------------------------------------------------- +; Single-bit-on words for setting individual pixels +;----------------------------------------------------------------------------- +Bit_Table label byte +; 01234567 (Pixel numbering - not bit numbering) + db 10000000b + db 01000000b + db 00100000b + db 00010000b + db 00001000b + db 00000100b + db 00000010b + db 00000001b +;----------------------------------------------------------------------------- +; Gradual bit filled bytes for the "left-side" of horizontal lines +;----------------------------------------------------------------------------- +Start_Line label byte +; 01234567 (Pixel numbering - not bit numbering) + db 11111111b + db 01111111b + db 00111111b + db 00011111b + db 00001111b + db 00000111b + db 00000011b + db 00000001b +;----------------------------------------------------------------------------- +; Gradual bit filled bytes for the "right-side" of horizontal lines +;----------------------------------------------------------------------------- +End_Line label byte +; 01234567 (Pixel numbering - not bit numbering) + db 10000000b + db 11000000b + db 11100000b + db 11110000b + db 11111000b + db 11111100b + db 11111110b + db 11111111b +;----------------------------------------------------------------------------- +; Clipping masks +;----------------------------------------------------------------------------- +; LTRB (left, top, right, bottom) +left_mask db 00001000b +top_mask db 00000100b +right_mask db 00000010b +bottom_mask db 00000001b +;----------------------------------------------------------------------------- +; Screen resolution table (for the different IBM video modes) +;----------------------------------------------------------------------------- +; The table contains the maximum *plottable* X,Y value for the mode. +Res_Table_IBM label word + dw 0,0 ;mode 0 not a graphics mode + dw 0,0 ;mode 1 not a graphics mode + dw 0,0 ;mode 2 not a graphics mode + dw 0,0 ;mode 3 not a graphics mode + dw 319,199 ;mode 4 is a graphics mode + dw 319,199 ;mode 5 is a graphics mode + dw 639,199 ;mode 6 is a graphics mode + dw 0,0 ;mode 7 not a graphics mode + dw 0,0 ;mode 8 PCjr only + dw 0,0 ;mode 9 PCjr only + dw 0,0 ;mode 10 PCjr only + dw 0,0 ;mode 11 EGA internal mode + dw 0,0 ;mode 12 EGA internal mode + dw 319,199 ;mode 13 is a graphics mode + dw 639,199 ;mode 14 is a graphics mode + dw 639,349 ;mode 15 is a graphics mode + dw 639,349 ;mode 16 is a graphics mode +;----------------------------------------------------------------------------- +; Jump table for graphit() based on op_code +;----------------------------------------------------------------------------- +OP_CODE dw SET_MODE + dw SETP + dw SET_PAL ; This used to be RESETP + dw LINE + dw GETP + dw VIDEO_MODE + dw BOX + dw FILLD_BX + dw SET_CLIP_RECT +table_len equ $ - OP_CODE +DATA ends +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +PROGX segment byte public 'PROGX' + assume CS:XGROUP,DS:DGROUP +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; name GRAPHIT -- Scheme interface to Rusty's graphics routines +; +; synopsis graphit(op, arg1, arg2, arg3, arg4, arg5, arg6); +; +; description call the appropriate graphics routine based on the "op" +; argument: +; 0 - (set-video-mode! mode) +; 1 - (setp x y color) +; 2 - (set-palette! curr-color-id new-color-id) +; 3 - (line x1 y1 x2 y2 color) +; 4 - (point x y) +; 5 - (get-video-mode) +; 6 - (box x-ul y-ul x-len y-len color) +; 7 - (filled_box x-ul y-ul x-len y-len color xor) +; 8 - (set-clipping-rectangle! left top right bottom) +; +gr_args struc + dw ? ; caller's BP + dd ? ; return address +arg6 dw ? ; argument 6 -- dbs 10/10/86 +arg5 dw ? ; argument 5 +arg4 dw ? ; argument 4 +arg3 dw ? ; argument 3 +arg2 dw ? ; argument 2 +arg1 dw ? ; argument 1 +opcode dw ? ; sub operation code +gr_args ends + + public graphit +graphit proc far + push BP ; save caller's BP + mov BP,SP + +; Load sub opcode + mov BX,[BP].opcode ; load sub operation code + add BX,BX ; adjust for index into jump table + cmp BX,table_len ; bad op_code? + jae bad_op +; cmp BX,0 ; "jae" serves as well +; jl bad_op + +; Call desired graphics function + call OP_CODE[BX] + jmp short gr_end + +bad_op: mov AX,-1 + +; Return to caller +gr_end: mov SP,BP ; dump arguments off TIPC's stack + pop BP ; restore caller's BP + ret ; return to caller +graphit endp + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name SET_MODE - graphics initialize +; +; synopsis (set-video-mode! mode_number) +; +; description TIPC | IBM-PC +; MODE ACTION | MODE ACTION(same as AH=0,INT 10H) +; --------------------------+--------------------------- +; 0 Clear graphics | 0 40x25 BW 4 320x200 Col +; 1 Text Enable | 1 40x25 Color 5 320x200 BW +; 2 Graphics Enable | 2 80x25 BW 6 640x200 BW +; 3 Text & Graphics Ena | 3 80x25 Color +; +--------------------------- +; | extra EGA modes: +; | 13 320x200 16col 40x25 8x8cbox +; | 14 640x200 16col 80x25 8x8cbox +; | 15 640x350 4col 80x25 8x14cbox +; | 16 640x350 16col 80x25 8x14cbox +; +; returns nothing +; +SET_MODE proc near + push BP + push ES + mov AX,[BP].arg1 ; Get mode-number + push AX ; Save mode number for later + cmp PC_MAKE,TIPC ; set IBM mode? + je ti_mode + +ibm_mode label near + +comment % ;;; Protected Mode + + Commented out 8/3/87 by TC + + mov AH,12H ; Test for presence of EGA + mov BX,10H + int IBM_CRT ; IBM's video BIOS interrupt + cmp CX,0 ; Is there an EGA here ? + je ibm_cga ; Apparently not; assume CGA + push DS + pop ES + mov DX,offset clear_pal + mov AX,1002H ; Set EGA palettes to black for mode + int IBM_CRT ; change without screen flicker + pop AX + push AX + xor AH,AH ; Set video I/O mode (AH=0) (AL=MODE) + int IBM_CRT ; IBM's video BIOS interrupt + call Reset_CR_IBM ; reset clipping rectangle to full screen + Initialize a delay loop + mov AH,2CH ; Get time + int DOS_FUN ; DOS function request + inc DH ; Add 1 second delay to start time + mov BX,DX ; Save the ending time + cmp BH,59 ; Test for 59 seconds (impossible limit) + jl tm_loop ; OK + mov BH,0 ; Set it = 0 to avoid a long delay +tm_loop: mov AH,2CH ; Get time + int DOS_FUN ; DOS function request + cmp DX,BX ; Enough time yet ? + jle tm_loop ; No, loop again + + mov DX,offset save_pal + mov AX,1002H ; Set EGA palettes to saved colors + int IBM_CRT ; IBM's video BIOS interrupt + jmp short mode_end +% + +ibm_cga label near + pop AX + push AX + xor AH,AH ; Set video I/O mode (AH=0) (AL=MODE) + int IBM_CRT ; IBM's video BIOS interrupt + call Reset_CR_IBM ; reset clipping rectangle to full screen + jmp short mode_end + +ti_mode: call Reset_CR_TI ; reset clipping rectangle to full screen + cmp AL,0 ; Clear TI graphics and re-init palette + je clr_grfx + cmp AL,1 ; Turn off Graphics and Text on + je textonly + cmp AL,2 ; Turn on Graphics and Text off + je grfxonly + cmp AL,3 ; Turn on both Graphics and Text + jne ti_err + jmp all_on +ti_err: + pop AX + xor AX,AX ; Bad op-code + not AX ; AX = -1 + jmp short err_ret + +mode_end: pop AX + mov VID_MODE,AX ; Save VID-MODE for (get-video-mode)[TI-only] + xor AX,AX ; Return something nice(?) + + mov char_hgt,8 + cmp vid_mode,14 + jle err_ret + mov char_hgt,14 + +err_ret: pop ES ; Get the heck outta here + pop BP + ret + +clr_grfx: + + IFDEF PROMEM ;;; Protected Mode +reg_block struc ; register block + dw ? ; AX + dw ? ; BX + dw ? ; CX + dw ? ; DX +reg_block ends + + push AX + push BX + push CX + push DX + + mov DX,SP + + + mov AH,0C4h ; Issue Real Interrupt + mov AL,TI_CRT ; TI CRT interrupt number + int DOS_FUN ; (extended dos function for protected mode) + ELSE + mov AH,14h ; Clear graphics planes + int TI_CRT ; Send command to CRT device driver + ENDIF + + mov RED_Latch,DEF_RED ; Reset palettes to default values + mov GRN_Latch,DEF_GRN + mov BLU_Latch,DEF_BLU + cmp byte ptr GRAFIX_ON,YES_GRPH + jne short mode_end + mov AL,RED_Latch ; if graphics are enabled reset the palettes + mov BL,GRN_Latch + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + jmp short mode_end + +grfxonly label near + mov AL,RED_Latch + mov BL,GRN_Latch + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + mov AL,TEXT_OFF + call txt_set ; Turn text off + jmp short mode_end + +textonly label near + xor AL,AL + mov BL,AL + mov CL,AL + mov DL,NO_GRAPH + call pal_set ; Set the graphics palettes off + mov AL,TEXT_ON + call txt_set ; Turn text on + jmp short mode_end + +all_on label near + mov AL,RED_Latch + mov BL,GRN_Latch + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + mov AL,TEXT_ON + call txt_set ; Turn text on + jmp mode_end + +pal_set label near + xor BP,BP ; Zero offset from palette segments + mov ES,RED_Palette + mov byte ptr ES:[BP],AL ; Set red palette + mov byte ptr ES:[BP]+16,BL ; Set green palette + mov byte ptr ES:[BP]+32,CL ; Set blue palette + mov byte ptr GRAFIX_ON,DL ; if graphics are on or not + ret + +txt_set label near + xor BP,BP + mov ES,Misc_Latch + mov byte ptr ES:[BP],AL + ret +SET_MODE endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name SETP -- turn on a pixel at the given coordinates with +; the specified color. +; +; synopsis (setp x y color) +; +; description Turn on the pixel at (x,y) [origin at upper left] with +; one of 8 colors specified by 'color'. +; Point clipping is done; ignore the ";;" comments. +; +;; The arguments +;; need not be in their proper range (i.e. a MOD of x, y, +;; and color will be done with their proper values to get +;; them into the correct range. [0 <= x <= 719, 0 <= y <= 299, +;; 0 <= color <= 7]). This will give a "wrap-around" effect. +;; On the IBM-PC with graphics adapter no range checking is done +;; on either the (x,y) coordinates or the color. +; +; returns nothing +; +SETP proc near + push BP + push DI + push ES +; + mov AX,[BP].arg1 ; Get `x' + mov BX,[BP].arg2 ; Get `y' +; call Fix_XY ; Force x and y into their proper ranges + call Encode_XY ; Encode point's visibility + cmp CL,0 ; is it visible? + jnz Set_exit ; no, jump + mov CX,[BP].arg6 ; xor code + mov f_code,CL + mov CX,[BP].arg3 ; Get `color' + call LCL_SETP ; Display pixel +Set_exit: xor AX,AX ; Return code of zero + pop ES + pop DI + pop BP + ret +SETP endp ; End of SETP(,,) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name SET_PAL -- Modify the current palette according to PC_MAKE +; +; synopsis (set-palette! curr-color-id new-color-id) +; +; description If PC_MAKE == TIPC then set-palette twiddles the TIPC +; graphics palette latches according to the colors specified. +; +; If PC_MAKE == [PC,XT,jr,AT] then use the IBM video I/O +; interrupt (10h), function 11, set color palette; +; or function 16, set palette registers if EGA is present. +; +; returns nothing +; +SET_PAL proc near + push BP + push ES + mov BX,[BP].arg1 ; Get current-color-id + mov CX,[BP].arg2 ; Get new-color-id +; **** WARNING **** Fix the IBM side of this swapping of A,BX <=> B,CX +; + cmp PC_MAKE,TIPC + jne ibm_pal + and BX,7 ; use only lower three bits + mov AL,Palette_Trans[BX] ; convert BL to 1-in-8 bits + mov AH,AL + not AH ; AH = 7-in-8 mask + mov BL,RED_Latch + call twiddle + mov RED_Latch,BL + mov BL,BLU_Latch + call twiddle + mov BLU_Latch,BL + mov BL,GRN_Latch + call twiddle + mov GRN_Latch,BL + cmp byte ptr GRAFIX_ON,YES_GRPH ; are graphics enabled? + jne pal_ret + mov AL,RED_Latch ; if yes, then update display palettes + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + jmp short pal_ret + +twiddle label near + sar CL,1 ; Do we turn the bit on or off + jnc turn_off + or BL,AL ; Turn it on + ret +turn_off: and BL,AH ; Turn it off + ret + +ibm_pal: mov AH,15 ; Get current video mode + int IBM_CRT ; IBM video I/O interrupt + cmp AL,4 ; Is mode = 4 ? + jne pal_ega ; No, jump + ; CGA palette + mov BH,BL ; BH = palette color id being set + mov BL,CL ; BL = color value + mov AH,11 ; Set CGA color palette + int IBM_CRT ; IBM video I/O interrupt + jmp short pal_ret + ; EGA palette +pal_ega: mov BH,CL ; BL = palette color id being set + ; BH = color value + cmp BL,16 ; Is color id reasonable ? + jge pal_ret ; No, forget it + mov AX,1000H ; Set EGA color palette + int IBM_CRT ; IBM video I/O interrupt + mov BH,0 ; Use palette color id (BL) as index + mov DS:save_pal[BX],CL ; Save color value in palette table + +pal_ret: xor AX,AX ; Return code of zero + pop ES + pop BP + ret +SET_PAL endp ; End of (set-palette!...) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name VIDEO_MODE - return the current video mode +; +; synopsis (get-video-mode) +; +; description Returns the video mode number for the appropriate PC. +; +; returns video mode number +; + public VIDEO_MODE +VIDEO_MODE proc near + cmp PC_MAKE,TIPC + je get_ti_m + mov AH,15 ; IBM's get current video state + int IBM_CRT + cbw ; Convert to full word. + ret + +get_ti_m: mov AX,VID_MODE ; This was squirreled away by SET_MODE (TI) + ret +VIDEO_MODE endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name LINE -- draw a line between the two sets of coordinates +; given with the specified color. +; +; synopsis (line x1 y1 x2 y2 color) +; +; description Draw a line between (x1,y1) and (x2,y2) with one of the 8 +; colors specified by 'color'. The line is clipped. +; +; This routine is based upon Bresenham's Line Algorithm +; from page 435 in "Fundamentals of Interactive Computer +; Graphics" by Foley and Van Dam. +; +; The clipping algorithm is Cohen and Sutherland's. +; See pages 65-67, "Principles of Interactive Computer Graphics" +; (2nd edition) by Newman and Sproull. +; +; returns nothing +; +LINE proc near + push DI + push SI + push ES + +; Clip line + + mov AX,[BP].arg1 ; Get x1 + mov BX,[BP].arg2 ; Get y1 + mov CX,[BP].arg3 ; Get x2 + mov DX,[BP].arg4 ; Get y2 + cmp AX,CX ; is x1 <= x2? + jle x1_first ; yes, jump + ; always draw from p1 to p2; otherwise the same line drawn + ; in the opposite direction may not exactly overlay it + xchg AX,CX ; no, interchange the two points + xchg BX,DX +x1_first: mov Curr_X,AX + mov Curr_Y,BX + mov Stop_X,CX + mov Stop_Y,DX + call Clip_line + jz Do_line ; jump if line is visible + jmp Line_exit ; jump if line is invisible + +; Line drawing proper + +Do_line: mov px,offset Curr_X ; px = address of Curr_X + mov py,offset Curr_y ; py = address of Curr_Y +; + mov BX,[BP].arg6 ; get xored or not + mov f_code,BL +; + mov AX,Stop_X + mov BX,Stop_Y + mov Xend,AX ; Independent var's end-value unless swapped + + sub BX,Curr_Y ; Delta_Y = y2 - y1 + mov Delta_Y,BX + sub AX,Curr_X ; Delta_X = x2 - x1 + mov Delta_X,AX + xchg AX,BX ; Put Delta_Y into ax; Delta_X into bx +; + jz Swap_Things ; Is Delta_X == 0 ? + cwd ; Ready dx for division + idiv BX + neg AX + jge Test_Slope + neg AX ; slope = ax = ABS(INT(dy/dx)) +Test_Slope label near + cmp AX,1 ; IF slope >= 1 THEN + jl Get_X_Increment +; +Swap_Things label near + xchg Delta_Y,BX + mov Delta_X,BX ; swap(dx,dy) + mov CX,px + xchg py,CX + mov px,CX ; swap(px,py) + mov CX,Stop_Y + mov Xend,CX ; Xend = Stop_Y since variables' + ; dependence was swapped. + ; ENDIF +Get_X_Increment label near + or BX,BX ; X_Dir = sgn(Delta_X) + jz Save_X_Dir ; IF it's zero THEN we're done + mov BX,1 ; ELSE force bx = 1 + jg Save_X_Dir ; IF Delta_X was < zero THEN + neg BX ; bx = -1 +Save_X_Dir label near + mov X_Dir,BX +; + mov BX,Delta_Y + or BX,BX ; Y_Dir = sgn(Delta_Y) + jz Save_Y_Dir ; IF it's zero THEN we're done + mov BX,1 ; ELSE force bx = 1 + jg Save_Y_Dir ; IF Delta_X was < zero THEN + neg BX ; bx = -1 +Save_Y_Dir label near + mov Y_Dir,BX +; + mov AX,Delta_X ; Delta_X = ABS(Delta_X) + neg AX + jge Save_ABS_Dx + neg AX +Save_ABS_Dx label near + mov Delta_X,AX +; + mov BX,Delta_Y ; Delta_Y = ABS(Delta_Y) + neg BX + jge Save_ABS_Dy + neg BX +Save_ABS_Dy label near + mov Delta_Y,BX +; + shl BX,1 + mov Incr1,BX ; Incr1 = Delta_Y * 2 + sub BX,AX + push BX ; d = Delta_Y * 2 - Delta_X + sub BX,AX + mov incr2,BX ; Incr2 = (Delta_Y - Delta_X) * 2 +; + mov CX,[BP].arg5 ; Push `color' for call to SETP + mov BX,Curr_Y ; Push `y' + mov AX,Curr_X ; Push `x' + call LCL_SETP ; Plot beginning point +; + mov DI,px ; Get pointer to independent variable + mov SI,py ; Get pointer to dependent variable + mov AX,X_Dir + mov BX,Y_Dir + mov CX,Xend + pop DX ; get D from stack +; +While label near + cmp CX,DS:[DI] ; While (px->start != xend) { + je While_End + add DS:[DI],AX ; Px->start += X_Dir + or DX,DX ; IF (D < 0) THEN + jge Inc_Dependent + add DX,Incr1 ; D += Incr1 + jmp short End_If +Inc_Dependent label near ; ELSE + add [SI],BX ; Py->start += Y_Dir + add DX,Incr2 ; D += Incr2 +End_If label near ; ENDIF + push AX ; Save X_Dir + push BX ; Save Y_Dir + push CX ; Save Xend + push DX ; Save D + push DI +; + mov CX,[BP].arg5 ; Push `color' for call to SETP + mov BX,Curr_Y ; Push `y' + mov AX,Curr_X ; Push `x' + call LCL_SETP ; Plot beginning point +; + pop DI + pop DX + pop CX + pop BX + pop AX + jmp short While +; +While_End label near +Line_exit label near + xor AX,AX ; Return code of zero + pop ES + pop SI + pop DI + ret +LINE endp ; End of LINE(,,,,) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name GETP -- return the attribute (color) at the specified +; coordinates. +; +; synopsis (getp x y) +; +; description Return the pixel value (0 - 7) at the coordinates given +; as arguments. The coordinates are clipped. +; +; returns An unsigned integer in the range 0 to 7 , inclusive, +; if the pixel lies inside the clipping rectangle. +; The first bit-plane starting at 0C0000h will have its +; bit represented by the lsb of the returned word. The +; last bit-plane starting at 0D0000h will have its bit +; represented by bit number 2 (lsb = bit 0) of the returned +; word. +; +; If the pixel lies outside the clipping rectangle, return -1. +; +GETP proc near + push BP + push DI + push ES +; + mov AX,[BP].arg1 ; Get `x' + mov BX,[BP].arg2 ; Get `y' +; call Fix_XY ; Force x and y into their proper ranges + call Encode_XY ; Encode point's visibility in the CR + cmp CL,0 ; is point visible in the CR? + mov AX,-1 + jne IBM_Ret_Clr ; no, jump (return -1 in AX) + mov AX,[BP].arg1 ; restore AX to 'x' + + cmp PC_MAKE,TIPC + je ti_getp +; + mov dx,bx ; Do it the IBM way (ugh!) + mov cx,ax + mov ah,13 + int IBM_CRT ; IBM Video BIOS + xor ah,ah ; Color is in AL + mov dx,ax + jmp short IBM_Ret_Clr + + +ti_getp label near + call GM_Offset ; Convert (x,y) to linear offset +; +; Read the specified bit in each of the graphics memory banks. +; + xor DX,DX ; Clear value to be returned + mov ES,Bank_C ; Get segment of 3rd bank + mov BH,ES:[DI] ; Copy the selected byte in graphics memory + and BH,AH ; Was the bit on ? + jz short Test_Bank_B + inc DX +; +Test_Bank_B label near + shl DX,1 + mov ES,Bank_B ; Get segment of 2nd bank + mov BH,ES:[DI] ; Copy the selected byte in graphics memory + and BH,AH ; Was the bit on ? + jz short Test_Bank_A + inc DX +; +Test_Bank_A label near + shl DX,1 + mov ES,Bank_A ; Get segment of 1st bank + mov BH,ES:[DI] ; Copy the selected byte in graphics memory + and BH,AH ; Was the bit on ? + jz short Return_Color + inc DX +; +Return_Color label near + mov AX,DX ; Put returning value into ax + +IBM_Ret_Clr label near + pop ES + pop DI + pop BP + ret +GETP endp ; End of GETP(,) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +; Encode_XY in: AX=X, BX=Y +; out: CL=code +; destroyed: CL +; +; Encode X,Y into a 4-bit code indicating its visibility in the clipping rectangle. +; The code is returned in CL: CL =0: point is visible +; CL<>0: point is invisible. +;----------------------------------------------------------------------------- +Encode_XY proc near + mov CL,0 ; clear CL; code is constructed here + cmp AX,clip_left ; x >= clip_left? + jge Enc_1 ; yes, jump + or CL,left_mask ; no, set bit +Enc_1: cmp BX,clip_top ; y >= clip_top? + jge Enc_2 ; yes, jump + or CL,top_mask ; no, set bit +Enc_2: cmp AX,clip_right ; x <= clip_right? + jle Enc_3 ; yes, jump + or CL,right_mask ; no, set bit +Enc_3: cmp BX,clip_bottom ; y <= clip_bottom? + jle Enc_4 ; yes, jump + or CL,bottom_mask ; no, set bit +Enc_4: ret +Encode_XY endp + + page +;----------------------------------------------------------------------------- +; Clip_line in: none +; out: none (Z flag) +; destroyed: AX,BX,CX,DX,SI,DI +; +; The line between (Curr_X, Curr_Y) and (Stop_X, Stop_Y) is clipped. +; The two points' coordinates are possibly modified during the process. +; On exit: Z=0 if line is visible (onscreen); the final coordinates +; are in the Curr and Stop memory locations +; Z=1 if line is invisible (offscreen) +;----------------------------------------------------------------------------- +Clip_line proc + mov DI,offset Stop_X + overlap Cli_exit,Cli_exit ; if line's extents rectangle lies wholly + ; inside or wholly outside clipping rectangle, + ; exit immediately + + jmp short Cli_loop ; else start clipping + +; At this point AX=new X and BX=new Y. +; (Note this is executed *after* the loop. It's rearranged to +; get all the relative branches within range.) + +Cli_join: + mov [DI],AX ; store X back into memory + mov [DI+2],BX ; ditto for Y + pop CX ; restore codes + call Encode_XY ; get code for new X and Y + + cmp CX,0 ; is combined code zero? + jz Cli_exit ; yes, jump; line totally visible at last + test CH,CL ; do any encoded bits line up? + jz Cli_loop ; no, jump; some part of line is visible. + ; if fall thru, line was invisible after all +Cli_exit: ret + +; We have to clip the line. + +Cli_loop: cmp CL,0 ; is this point visible? + jnz Cli_1 ; no, jump + xchg CH,CL ; yes, go work on other point + sub DI,4 ; set pointer to other point +Cli_1: push CX ; tempsave the codes + test CL,left_mask ; is point off left side? + jz Cli_2 ; no, jump + ; The endpoint is to the left of the clipping rectangle. + intersect clip_left,Stop_Y,Stop_X,Curr_X,Curr_Y + mov BX,AX ; new Y + mov AX,clip_left ; new X + jmp Cli_join +Cli_2: test CL,top_mask ; is point off top side? + jz Cli_3 ; no, jump + ; The endpoint is above the top of the clipping rectangle. + intersect clip_top,Stop_X,Stop_Y,Curr_Y,Curr_X + ; AX contains new X already + mov BX,clip_top ; new Y + jmp Cli_join +Cli_3: test CL,right_mask ; is point off right side? + jz Cli_4 ; no, jump + ; The endpoint is to the right of the clipping rectangle. + intersect clip_right,Stop_Y,Stop_X,Curr_X,Curr_Y + mov BX,AX ; new Y + mov AX,clip_right ; new X + jmp Cli_join +Cli_4: ; no need for more tests + ; The endpoint is below the bottom of the clipping rectangle. + intersect clip_bottom,Stop_X,Stop_Y,Curr_Y,Curr_X + ; AX contains new X already + mov BX,clip_bottom ; new Y + jmp Cli_join + +Clip_line endp + + page +;----------------------------------------------------------------------------- +; Clip_box in: none +; out: none +; destroyed: AX +; +; The box with corners (Curr_X, Curr_Y) and (Stop_X, Stop_Y) is clipped. +; (The corners should be (left,top) and (right,bottom) respectively.) +; The two points' coordinates are possibly modified during the process. +;----------------------------------------------------------------------------- +Clip_box proc + mov AX,clip_left + cmp Curr_X,AX + jge CB_1 + mov Curr_X,AX +CB_1: mov AX,clip_top + cmp Curr_Y,AX + jge CB_2 + mov Curr_Y,AX +CB_2: mov AX,clip_right + cmp Stop_X,AX + jle CB_3 + mov Stop_X,AX +CB_3: mov AX,clip_bottom + cmp Stop_Y,AX + jle CB_4 + mov Stop_Y,AX +CB_4: ret +Clip_box endp + + page +;----------------------------------------------------------------------------- + + comment ~ + +; NOTE: This routine is no longer called. Clipping is done instead. - rb + +Fix_XY proc near ; Force x and y into their proper values + cmp PC_MAKE,TIPC + jne ibm_dsnt ; IBM doesn't do range checking, Y should I? + ; On IBM, the ranges will vary with the mode + ; On entry ax = `x', bx = `y' + ; On exit ax = ax MOD 720, bx = bx MOD 300 + ; cx & dx = + ; Get `x';fix to proper range (already in ax) + xor DX,DX ; Clear DX - unsigned dbl-word + div X_Resolution ; ax = INT(x / 720), dx = (x MOD 720) + mov CX,DX ; I want the MOD function.... + ; + mov AX,BX ; Get `y' and fix to proper range + xor DX,DX ; Clear DX - unsigned dbl-word + div Y_Resolution ; ax = INT(y / 300), dx = (y MOD 300) + ; I want the MOD function.... + mov BX,DX + mov AX,CX ; Put `x' back +ibm_dsnt: ret +Fix_XY endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + ~ ;end comment + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +GM_Offset proc near +; +; Determine which word needs modifying and which bit to set. +; byte_offset = (Curr_Y * 736-bits/y_pixel * 1-byte/8-bits) +; + INT(Curr_X * 1-byte/8-x_pixels) +; bit-in-byte = Curr_X MOD 8 [0-msb, 8-lsb in byte] +; + ; On entry ax = `x', bx = `y' + ; On exit + ; ah = bit-in-byte, bx = + ; cx = , dx = + ; di = byte-addr into graphics memory + xchg AX,BX ; now ax = `y' & bx = `x' +; neg AX ; Translate y=0 to bottom of screen +; add AX,Y_MAX-1 ; y_new = 299 - (y_old MOD 300) +; mul Bytes_per_Line ; Curr_Y * 736/8-bytes/y_pixel + shl AX,1 ; 2-clocks + shl AX,1 ; 2-clocks + mov DX,AX ; 2-clocks + shl AX,1 ; 2-clocks + add AX,DX ; 3-clocks + neg DX ; 3-clocks + shl AX,1 ; 2-clocks + shl AX,1 ; 2-clocks + shl AX,1 ; 2-clocks + add AX,DX ; 3-clocks + ; TOTAL = 23-clocks + ; MUL = (128-143)+EA + xchg AX,BX ; ........save partial sum + ; and get `x' into accumulator +; xor DX,DX ; Clear DX - unsigned dbl-word +; div Bits_per_Byte ; ax = word offset from beginning of line + ; dx = bit-in-byte (x MOD 8) + mov DX,7 ; mask all bits 'cept lower 3 + ; 4-clocks + and DX,AX ; 3-clocks + shr AX,1 ; 2-clocks + shr AX,1 ; 2-clocks + shr AX,1 ; 2-clocks + ; TOTAL = 13-clocks + ; DIV = (154-172)+EA + add AX,BX ; Ax = byte # offset into graphics bank + xor AL,1 ; fix byte offset address to jive with + ; Intel's screwy byte ordering!!! + mov DI,AX ; move for addressing graphics memory + mov BX,DX ; Saves on number of memory accesses + mov AH,Bit_Table[bx] ; Ax = bit-pattern + mov AL,AH + not AL ; al = NOT ah - for turning bits off + ret +GM_Offset endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; + public LCL_SETP +LCL_SETP proc near + cmp PC_MAKE,TIPC + je ti_setp + cmp VID_MODE,14 + jl ibm_setp + cmp f_code,1 + jne ibm_setp + or CL,080h ; set xor flag on + +ibm_setp: mov DX,BX ; Move arguments around for IBM + xchg CX,AX + xor BH,BH ; video plane + mov AH,12 ; write dot + int IBM_CRT + ret + +ti_setp label near + call GM_Offset ; Convert (x,y) to byte offset +; +; Determine which graphics memory banks get their bits twiddled. +; + +Set_Byte: mov ES,Bank_A ; Get segment of 1st bank + call set_pixel +; + mov ES,Bank_B + call set_pixel ; Turn on the proper bit +; + mov ES,Bank_C + call set_pixel ; Turn on the proper bit +; +Quit_n_Quit label near ; Save the current X & Y and return + ret +LCL_SETP endp + +set_pixel proc near + shr CL,1 ; Do we turn on/off bit in this bank? + jnc short this_bank ; If bit was on (one) then + + cmp f_code,1 ; is the bit xored? + jne set_01 + + mov BL,ES:[DI] ; get current value + xor BL,AH ; xor with mask + mov ES:[DI],BL ; replace value + ret + +set_01: or ES:[DI],AH + ret + +this_bank label near + cmp f_code,1 ; xored? + je set_02 + and ES:[DI],AL ; Turn off the proper bit +set_02: ret +set_pixel endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name BOX -- Draw a box in the graphics plane with the +; specified color. +; +; synopsis (box x-ul y-ul x-lr y-lr color) +; +; description Draw a box with graphics (not text characters). The +; upper left-hand corner is specified by (x-ul,y-ul) +; and the lower right-hand is specified by (x-lr,y-lr). +; Color indicates the pixel values that will make up the +; box. The interior will not be filled nor modified +; in any way. The box is clipped. +; Edges that are clipped are "shrunk inwards" to fit +; snug against the corresponding edges of the clipping +; rectangle. The result is another box and not just +; some line segments as you'd might expect. +; +; returns nothing +; +BOX proc near + mov Fill_Fig,FALSE ; This box ain't getting filled +BOX_2ND label near ; A secondary entry point for FILLED_BOX + push SI + mov AX,[BP].arg1 ; Get x upper-left + mov BX,[BP].arg2 ; Get y upper-left +; call Fix_XY ; Force x-ul and y-ul into correct ranges + mov Curr_X,AX + mov Curr_Y,BX + mov AX,[BP].arg3 ; Get x lower-right + mov BX,[BP].arg4 ; Get y lower-right +; call Fix_XY ; Force x-lr and y-lr into correct ranges +; + cmp AX,Curr_X + jg check_y ; Swap if x-lr < x-ul + xchg AX,Curr_X +check_y: cmp BX,Curr_Y + jg goodargs ; Swap if y-lr < y-ul (origin at top-left) + xchg BX,Curr_Y +; +goodargs: mov Stop_X,AX ; (var. Stop used during clipping only) + mov Stop_Y,BX + overlap box_1,box_done_1 ; if box totally inside CR, no need to clip + ; if box totally outside, skip it + call Clip_box ; else clip box to the clipping rectangle +box_1: mov AX,Stop_X + mov BX,Stop_Y +; + sub BX,Curr_Y + inc BX ; BX = the height of the box (min=1-pixel) + mov Box_Hite,BX + mov BX,[BP].arg6 ; get function code + mov f_code,BL + mov BX,[BP].arg5 ; get the color + mov pix_c,BX +; + cmp PC_MAKE,TIPC ; All the "common" material taken care of + je BOX_TI + jmp BOX_IBM +; +box_done_1: jmp Box_done ; rel. branch not long enough +; + +BOX_TI: mov BX,Curr_Y ; find upper right-hand corner address + mov y_val,BX + call GM_Offset + push DI ; save offset into graphics mem + push BX ; save bit-number +; + mov AX,Curr_X ; find upper left-hand corner address + mov BX,Curr_Y + call GM_Offset + mov Left_Offset,DI ; Offset into graphics plane of upper-left + xor DI,1 ; This craziness is due to *^&$%! Intel +; + mov AH,Start_Line[BX] ; Get left-end bit pattern + mov AL,AH + not AL ; Need (0ffh - AH) for Set_Byte() + mov DH,Bit_Table[BX] ; Get left-siding bit pattern + mov DL,DH + not DL ; Need (0ffh - DH) for Set_Byte() + mov Left_End,AX + mov Left_Side,DX +; + pop BX + mov AH,End_Line[BX] ; Get right-end bit pattern + mov AL,AH + not AL ; Need (0ffh - AH) for Set_Byte() + mov DH,Bit_Table[BX] ; Get right-siding bit pattern + mov DL,DH + not DL ; Need (0ffh - DH) for Set_Byte() + mov Right_End,AX + mov Right_Side,DX +; + pop CX + xor CL,1 ; This craziness due to #$%&! Intel + sub CX,DI + inc CL + mov Box_Width,CX ; CX = Number of bytes in box's width + cmp CL,1 ; are bits in the same byte? (narrow box) + jg wide_box ; jump if not +; + ; We need to combine the "ends" and "sides" + ; for a byte-wide box. + and AH,byte ptr Left_End+1 ; combine left-end and right-end + mov AL,AH + not AL + or DH,byte ptr Left_Side+1 ; combine left-side and right-side + mov DL,DH + not DL + mov Left_End,AX + mov Left_Side,DX +; +wide_box label near + mov DL,CL ; CL = width in bytes + mov DH,byte ptr [BP].arg5 ; get color of box + xor DI,1 ; This squirreliness is due to $%^&*! Intel + call Solid_Line ; Draw top of BOX + dec Box_Hite +Box_Loop: jz Box_Done +; + add Left_Offset,Bytes_per_Line ; goto next scan line + mov DI,Left_Offset + mov DL,byte ptr Box_Width ; just get the lower byte + cmp Box_Hite,1 + je Bottom_Line +; + cmp Fill_Fig,TRUE ; Do we draw a filled or hollow box? + jne Do_Hollow +; + call Solid_Line ; Draw a solid horizontal line + jmp short BLoop_End +; +Do_Hollow: call Just_Ends ; Draw just the side points +BLoop_End: dec Box_Hite + jmp short Box_Loop +; +; +Bottom_Line: mov AX,stop_y + mov y_val,AX + call Solid_Line ; Draw the bottom of the box (if >1 high) +Box_Done: xor AX,AX ; Return a value of zero + pop SI + ret +; +; +Solid_Line label near + cmp f_code,1 + jne S_Line_1 + push DX + call ti_xxset + pop DX + ret + +S_Line_1: mov AX,Left_End ; Get the bit pattern for left-most byte + mov CL,DH ; Get the color + call Set_Byte + xor DI,1 ; This craziness is due to %$&*@! INTEL! + dec DL + jz SLine_Done +S_Loop: cmp DL,1 + je Last_Byte ; Jump if we need the right side +; + mov AX,0FF00h ; Get the solid (FFh) pattern + mov CL,DH + inc DI ; Point to next byte in graphics memory + xor DI,1 ; This craziness is due to %$&*@! INTEL! + call Set_byte + xor DI,1 ; This craziness is due to %$&*@! INTEL! + dec DL + jmp S_Loop +; +Last_Byte: mov AX,Right_End ; Get the bit pattern for right-most byte + inc DI + mov CL,DH ; Get color + xor DI,1 ; This craziness is due to %$&*@! INTEL! + call Set_Byte +SLine_Done: ret +; +Just_Ends label near + mov AX,Left_Side + mov CL,DH + call Set_Byte + xor DI,1 ; This craziness is due to %$&*@! INTEL! + dec DL + jz Hollow_End + add DI,Box_Width + dec DI ; Went one too far with addition + mov AX,Right_Side + mov CL,DH + xor DI,1 ; This craziness is due to %$&*@! INTEL! + call Set_Byte +Hollow_End: ret +; +; +; IBM (ugh!) version of draw box (sorry, but to maintain compatability +; among all the IBM video modes I've used the write-dot function (slow). +; +; modified - 10/10/86 for EGA +; +BOX_IBM label near + sub AX,Curr_X + inc AX ; Box_Width (number of pixels to draw line) + mov Box_Width,AX + call IBM_Solid ; Draw the top line of box + inc Curr_Y + dec Box_Hite + jz Box_Done +IBM_while: cmp Box_Hite,1 + je IBM_botm ; Go draw bottom line + cmp Fill_Fig,TRUE ; Is box to be filled or not? + jne IBM_nofill + call IBM_Solid + jmp short IBM_fi +; +IBM_nofill: call IBM_epts ; Draw the side points for current scan line +IBM_fi: inc Curr_Y ; end of "if" + dec Box_Hite + jmp IBM_while + +IBM_botm: call IBM_Solid ; Draw bottom line (needs to be solid) + jmp Box_Done +; +IBM_Solid label near ; Draw a solid horizontal line + + mov DI,Box_Width ; sounds more like a room freshener :-) + mov DX,Curr_Y + mov CX,Curr_X + + cmp vid_mode,14 + jge ega_box + + mov BL,byte ptr [BP].arg5 ; Get the color +I_Sloop: mov AH,0Ch ; write-dot function + mov AL,BL ; copy the color + int IBM_CRT ; WRITE-DOT(x,y,color) + inc CX + dec DI + jnz I_Sloop + ret +; +IBM_epts label near ; Draw the end points of a horizontal line + mov DX,Curr_Y + mov CX,Curr_X + mov BL,byte ptr [BP].arg5 ; Get the color + call epts + cmp Box_Width,1 ; Do we need to do the other end? + je I_eend + add CX,Box_Width + dec CX ; We added 1 too many + call epts +I_eend: ret + +epts proc near + mov AH,0Ch ; write-dot function + mov AL,BL + cmp f_code,1 + jne epts_01 + or AL,080h ; set xor bit +epts_01: int IBM_CRT ; Write Left dot + ret +epts endp + +;******************************************************************** +;* * +;* EGA_BOX will draw a solid line on the EGA screen. This method * +;* is used in preference to write dot since write dot is so slow.* +;* * +;* DX = start row * +;* CX = start col * +;* DI = length * +;* * +;******************************************************************** + +ega_box: mov AX,CX ; put start col into AX + add AX,DI ; AX is not the ending column + dec AX ; added one too many + call xxset + ret +BOX endp + + public xxset +XXSET PROC NEAR + + PUSH ES + PUSH DX + PUSH DX + PUSH AX + + MOV FUNC,0 ; DEFAULT TO DATA UNMODIFIED + CMP F_CODE,0 ; IS THIS An xor'ed box? + JE AND_TYPE + MOV FUNC,18H ; SET TO XOR +AND_TYPE: + MOV AX,CX ; PUT THE START COLUMN IN + MOV BX,DX ; PUT THE ROW IN + CALL GET_OFFSET ; CALCULATE START ADDR, OFFSET + CMP BX,8 ; ON A WORD BOUNDARY? + JL BYTE_01 ; YES, THEN CONTINBUE + INC AX ; BUMP THE WORD OFFSET + SUB BX,8 ; ADJUST FOR NEW BYTE ADDRESS +BYTE_01: + MOV ST_WORD,AX ; SAVE START ADDRESS AND + MOV ST_BIT,BX ; BIT OFFSET + + POP AX ; RESET THE END COLUMN + POP BX ; POP DX INTO BX - ROW + CALL GET_OFFSET ; CALCULATE END ADDR, OFFSET + CMP BX,8 ; ON A WORD BOUNDARY? + JL BYTE_02 ; YES, THEN CONTINBUE + INC AX ; BUMP THE WORD OFFSET + SUB BX,8 ; ADJUST FOR NEW BYTE ADDRESS +BYTE_02: + MOV ED_WORD,AX ; SAVE START ADDRESS AND + MOV ED_BIT,BX ; BIT OFFSET + +; Now to set up the addresses and masks and write to the planes + MOV DI,ST_WORD ; SET THE STARTING OFFSET + +XOR_LOOP: + MOV AL,-1 + CMP DI,ST_WORD ; STARTING OFFSET? + JNE END_OFF ; IF NOT, THEN CHECK FOR ENDING OFFSET + MOV CX,ST_BIT ; SUBTRACT THE STARTING BIT OFFSET + SHR AL,CL ; SET UP THE CORRECT MASK FOR START +END_OFF: ; End of offset processing + CMP DI,ED_WORD ; IS THIS THE LAST BYTE TO PROCESS? + JNE DO_XOR ; NO, THEN XOR THE DATA AND UPDATE + MOV AH,-1 ; INITIALIZE THE MASK + MOV CX,7 + SUB CX,ED_BIT ; SUBTRACT THE # OF ENDING OFFSET + SHL AH,CL ; WANT TO SAVE ALL BUT BITS PAST END + AND AL,AH ; AND OFF ALL USELESS BITS +DO_XOR: + + ; Latch up the current mask + PUSH AX + MOV DX,3CEH ; LATCH PORT + MOV AL,8 ; BIT MASK = on + OUT DX,AL + INC DX + POP AX ; RESTORE THE CURRENT MASK + OUT DX,AL + + CMP FUNC,18H + JNE WRT_ZEROS ; IF XOR, THE ONLY DO 1'S + +; Set to XOR function + DEC DX + MOV AL,3 ; DATA ROTATE REGISTER + OUT DX,AL ; WRITE IT + MOV AL,FUNC ; SET THE XOR OPERATOR + INC DX ; to or everything on to the planes + OUT DX,AL + JMP WRT_ONES + +WRT_ZEROS: +; Write the one to the planes that are set + + MOV DX,3C4H ; SEQUENCER ADDRESS + MOV AL,2 ; + OUT DX,AL + + MOV AX,PIX_C ; SET THE COLOR INTO THE AL + XOR AL,0FH ; SET THE ZERO PLANES TO ON + INC DX + OUT DX,AL ; ENABLE THIS PLANE + MOV ES,gra_ram ; GRAPHICS RAM ADDRESS + + MOV AL,ES:[DI] ; LATCH UP THE EXISTING DATA + XOR AL,AL ; WRITE ZEROES + MOV ES:[DI],AL ; OR WORD IN GRAPHICS PLANE. + +; Now write to the planes that are ONESes + +WRT_ONES: + MOV DX,3C4H ; SEQUENCER ADDRESS + MOV AL,2 ; + OUT DX,AL + + MOV AX,PIX_C ; SET THE COLOR INTO THE AL + INC DX + OUT DX,AL ; ENABLE THIS PLANE + MOV ES,GRA_RAM ; GRAPHICS RAM ADDRESS + + MOV AL,ES:[DI] ; LATCH UP THE EXISTING DATA + MOV AL,0FFH ; WRITE ONES + MOV ES:[DI],AL ; OR WORD IN GRAPHICS PLANE. + +; Now ready to update the pointers and continue + +NEXT_BYTE: + + CMP DI,ED_WORD ; PROCESSED LAST ONE? + JE XOR_EXIT + INC DI ; NEXT WORD IN THE GRAPHICS PLANES + JMP XOR_LOOP ; DO NEXT BYTE + +XOR_EXIT: + + MOV DX,3C4H ; SEQUENCER ADDRESS + MOV AL,2 ; + OUT DX,AL + + MOV AL,0FFH ; ENABLE ALL BAMNK + INC DX + OUT DX,AL ; ENABLE THIS PLANE + + MOV DX,3CEH ; SEQUENCER ADDRESS + MOV AL,3 ; + OUT DX,AL + + MOV AL,0 ; NORMAL WRITES + INC DX + OUT DX,AL ; ENABLE THIS PLANE + + DEC DX + MOV AL,8 ; + OUT DX,AL + + MOV AL,0FFH ; ALL BITS + INC DX + OUT DX,AL ; ENABLE THIS PLANE + + POP DX + POP ES + RET +; +XXSET ENDP + + +get_offset proc near + +; AX has the pixel column number +; BX has the pixel row number + + div b_p_wrds ; divide by bits per word + push AX ; save the bit offset + mov AX,BX ; get the pixel row + mul w_p_row ; row * 46 words per row + pop BX ; get words and bit within row + push BX ; save it again + xor BH,BH ; get rid of bit + add AX,BX ; bump to absolute offset + mul two ; byte offset! + pop BX + mov BL,BH ; shift bit count to bl + xor BH,BH + ret + ; return - ax=word offset ; bx=bit offset + +get_offset endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page + +;*************************************************************************** +; XXSET - PUT A LINE ON THE SCREEN AT THE START, END LOC AND OF LENGTH L +; AX=START COL, BX=START ROW , CX=END COL +; COLOR = COLOR +;*************************************************************************** + public ti_xxset +ti_xxset proc near + push ES +; + mov AX,curr_x + mov BX,y_val + mov CX,stop_x +; + push BX ; save the start row + call get_offset ; convert row/col to word/bit offset + + mov st_word,AX ; save the start row offset + mov st_bit,BX ; save the start bit offset + pop BX ; restore the start row + mov AX,CX ; get the ending col + call get_offset ; convert to word/bit offset + + mov ed_word,AX ; save the ending word offset + mov ed_bit,BX ; save the ending bit offset +; Determine the starting word mask + mov BX,st_word ; get the starting word offset +ti_xloop: + mov DX,-1 + cmp BX,st_word + jne ti_endoff + mov CX,st_bit ; starting bit offset + shr DX,CL ; shift off one bits until mask gotten +ti_endoff: + cmp BX,ed_word ; last byte to process? + jne ti_xor ; no. then xor and update + push DX ; save mask + mov DX,-1 ; initialize mask + mov CX,0fh + sub CX,ed_bit ;subtract the # of ending offset + shl DX,CL ; want to save allbut bits past end + pop AX ; and off all useless bits + and DX,AX + +ti_xor: mov CX,pix_c ; get the color + call ti_xor_word + cmp BX,ed_word + je ti_exit + + add BX,2 ; bump the offset to next word + jmp ti_xloop ; do next word +ti_exit: + pop ES + inc y_val + ret +; +ti_xxset endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page + +;***************************************************************************** +; XOR_WORD - XOR THE MASK IN THE DX INTO THE 3 GRAPHICS PLANES AT OFFSET +; XOR THE DATA INTO THE THREE GRAPHICS PLANES +; BX = WORD OFFSET , DX=MASK , CX=COLOR +;**************************************************************************** + +ti_xor_word proc near + + test CX,01h ; xor this plane only if bit set + jz xor_b ; no, then go to b plane + mov ES,bank_a ; get the seg addr of the a plane + call doit +; +xor_b: + test CX,02h ; xor this plane only if bit set + jz xor_c ; no, then go to c plane + mov ES,bank_b ; get the seg addr of the b plane + call doit + +xor_c: + test CX,04h ; xor this plane only if bit set + jz xor_end ; no, then go bump the offset + mov ES,bank_c ; get the seg addr of the c plane + call doit + +xor_end: + ret +ti_xor_word endp + +doit proc near + mov AX,ES:[BX] ; get the word from a plane + xor AX,DX ; xor the word + mov ES:[BX],AX ; put it back + ret +doit endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name FILLED_BX -- Draw a solid box in the graphics plane with the +; specified color. +; +; synopsis (filled_box x-ul y-ul x-lr y-lr color) +; +; description Draw a filled box with graphics (not text characters). +; The upper left-hand corner is specified by (x-ul,y-ul) +; and the lower right-hand is specified by (x-lr,y-lr). +; Color indicates the pixel values that will make up the +; box. The interior will be filled with the same color +; as the box. The box is clipped. +; +; returns nothing +; +FILLD_BX proc near + mov Fill_Fig,TRUE + call BOX_2ND ; Call BOX at a second entry point + ret +FILLD_BX endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +; name SET_CLIP_RECT - Set the clipping rectangle. +; +; synopsis (set-clipping-rectangle! left top right bottom) +; +; description This routine sets the clipping rectangle for the screen. +; The coordinate values can be any signed integer. The +; intersection of the clipping rectangle and the screen is +; used as the final clipping rectangle. If this would be nil, +; the clipping rectangle is set to the full screen; we never +; let it become invisible. +; +; returns nothing +; +; in: no registers +; out: no registers +; destroyed: AX,BX,CX,DX +;----------------------------------------------------------------------------- +SET_CLIP_RECT proc near + cmp PC_MAKE,TIPC + je SCR_TI + call Reset_CR_IBM ; set CR to screen's full size + jmp short SCR_join +SCR_TI: call Reset_CR_TI ; set CR to screen's full size +SCR_join: mov AX,[BP].arg1 + mov BX,[BP].arg2 + mov CX,[BP].arg3 + mov DX,[BP].arg4 + ; rearrange coordinates so first point is upper left hand corner + cmp CX,AX ; swap if x-lr < x-ul + jg SCR_1 + xchg CX,AX +SCR_1: cmp DX,BX ; swap if y-lr < y-ul (origin at top left) + jg SCR_2 + xchg DX,BX + ; now we can continue +SCR_2: mov Curr_X,AX ; store for the overlap check + mov Curr_Y,BX + mov Stop_X,CX + mov Stop_Y,DX + overlap SCR_3,SCR_4 ; check how screen and CR overlap + call Clip_box ; they overlap, clip +SCR_3: mov AX,Curr_X ; move new coords to be final CR + mov clip_left,AX + mov BX,Curr_Y + mov clip_top,BX + mov AX,Stop_X + mov clip_right,AX + mov BX,Stop_Y + mov clip_bottom,BX +SCR_4: ret +SET_CLIP_RECT endp + + page +;----------------------------------------------------------------------------- +; Reset the clipping rectangle to the full size of the screen for IBM modes. +; Destroys AX and BX. +;----------------------------------------------------------------------------- +Reset_CR_IBM proc near + mov AH,15 ; get the current video mode + int IBM_CRT + cmp al,16 ; cmp with max video mode (EGA 16) + jbe RCI_1 + mov al,16 ; map out-of-range values to EGA 16 +RCI_1: cbw + shl AX,1 ; multiply by 4 + shl AX,1 + mov BX,AX + mov clip_left,0 ; set the clipping rectangle accordingly + mov clip_top,0 + mov AX,Res_Table_IBM[BX] + mov clip_right,AX + mov AX,Res_Table_IBM+2[BX] + mov clip_bottom,AX + ret +Reset_CR_IBM endp + +;----------------------------------------------------------------------------- +; Reset the clipping rectangle to the full size of the screen for TIPC. +; No registers are affected. +;----------------------------------------------------------------------------- +Reset_CR_TI proc near + mov clip_left,0 + mov clip_top,0 + mov clip_right,X_max-1 + mov clip_bottom,Y_max-1 + ret +Reset_CR_TI endp + + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name XPCINIT - Any special initialization required for a +; particular type PC (e.g. IBM) +; +; synopsis call far xpcinit (from PGROUP) +; +; description A C callable routine (well, almost) that should be used +; internally to PCS for any special initialization that may +; be needed for a particular PC. +; +; returns nothing ('cept personal satisfaction) +; + public XPCINIT +XPCINIT proc far + cmp PC_MAKE,TIPC + jne not_ti + + IFDEF PROMEM ;;; Protected Mode + lea DI,Bank_A ; Segment Address of Bank A + mov SI,4 + cld +INISEG: mov BX,[DI] ; Get real mode segment address + xor CX,CX + mov DX,0FFFFh ; Length of segment + mov AH,0C0H ; Create Real Data Window + int DOS_FUN ; (extended Dos function for protected mode) + stosw ; Save Segment Selector to memory address + dec SI + jnz iniseg + ENDIF + + mov w_p_row,46 + mov AX,offset XGROUP:endinit ; THIS IS REALLY UGLY!!! + push AX ; push return address (return from all_on) + push BP + push ES + push VID_MODE + jmp all_on ; Turn on TEXT, init & clear graphics +; +not_ti: +COMMENT % + IFDEF PROMEM ;;; Protected Mode + mov BX,GRA_RAM ; Segment Address of EGA GRAPHICS RAM + xor CX,CX + mov DX,0FFFFh ; Length of segment + mov AL,0C0H ; Create Real Data Window + int DOS_FUN ; Extended Dos function for protected mode + mov GRA_RAM,AX ; Save Segment Selector + ENDIF +% + cmp PC_MAKE,0FCh + jl not_ibm + mov AX,0500h ; Set active display page (for alpha modes) + int IBM_CRT ; should I check for graphics mode??? Nah! + + mov AH,15 ; get current video mode + int IBM_CRT + xor AH,AH ; clear AH + mov VID_MODE,AX ; save videomode + + mov w_p_row,40 + + cmp AX,16 + jne short endinit + mov char_hgt,14 + + jmp short endinit +; +not_ibm label near ; Could there be a Zenith Z-100 out there? + ; Not for now. +endinit: ret +XPCINIT endp + +PROGX ends + end + \ No newline at end of file diff --git a/graphics.asm b/graphics.asm new file mode 100644 index 0000000..30569b0 --- /dev/null +++ b/graphics.asm @@ -0,0 +1,3125 @@ +; =====> GRAPHICS.ASM + name graphics + title PC Scheme Graphics + page 60,132 + +;----------------------------------------------------------------------------- +; +; TITLE: PC Scheme Graphics +; AUTHOR: Medford W. Haddock II (Rusty) +; DATE: October 20, 1983 +; COMPUTER: Texas Instruments Professional Computer with 3-plane graphics +; IBM PC with Color, Enhanced, or Professional Graphics Adapters +; ABSTRACT: These routines are designed to interface between PC Scheme +; and the color graphics board for both the IBM and TI PCs. +; REVISIONS: ds 9/25/86 - added support for the IBM EGA modes 14 and 16 +; rb 11/ 7/86 - added point, line, box clipping (both TI and IBM) +; rb 11/24/86 - fix line drawn from p1 to p2 not same as +; line drawn from p2 to p1 +; mrm 4/15/87 - modified set-mode! to run w/o screen flicker +; modified set-palette! to save EGA colors +; rb 6/13/87 - use CR for EGA mode 16 for illegal mode values +; rb 9/ 4/87 - added Hercules support and rewrote TI box support +; rb 10/20/87 - added conditionals for separate drivers; +; new VGA entries; IBM illegal modes use CR for +; last entry in resolution table +; rb 10/30/87 - do screen writes instead of BIOS for faster EGA +; rb 11/ 6/87 - removed delay loop from set-mode! +; +;----------------------------------------------------------------------------- + + include screen.equ + +;----------------------------------------------------------------------------- +; To generate the different graphics drivers, use this table to determine +; which symbols need to be defined with /D from the command line: +; +; VMXLI COMBINED XLICOMB XLI TI IBM HER | .OBJ file +; | +; VM intrinsic: 0 1 0 0 1 1 1 | graphcmd +; XLI inside VM: 1 0 0 0 0 0 0 | xpcinit +; XLI TI: 0 0 0 1 1 0 0 | graphti +; XLI IBM: 0 0 0 1 0 1 0 | graphibm +; XLI HER: 0 0 0 1 0 1 1 | graphher +; XLI combined: 0 1 1 1 1 1 0 | graphics +;----------------------------------------------------------------------------- + +IFDEF PROMEM + include pcmake.equ +;Protected Mode XLI driver needs all the following symbols defined +COMBINED equ 'defined' +XLICOMB equ 'defined' +XLI equ 'defined' +TI equ 'defined' +IBM equ 'defined' +ENDIF + + IFNDEF XLI + include pcmake.equ + ENDIF ;XLI + + page +;----------------------------------------------------------------------------- +; The "intersect" macro. in: none +; out: AX=intersect value +; destroys: AX,BX,CX,DX,SI +; usage: intersect L,y2,x2,x1,y1 (be careful of the funny ordering) +; +; Given a line that crosses a clipping edge, determine the point of +; intersection: one of the coordinates is that of the clipping edge, +; and this macro calculates the other coordinate. +; +; The equation pattern is: new-y = y1 + (y2 - y1) * (L - x1) / (x2 - x1). +;----------------------------------------------------------------------------- +intersect macro L,y2,x2,x1,y1 + mov AX,L + mov BX,y2 + mov CX,x2 + mov DX,x1 + mov SI,y1 + sub BX,SI ;; y2 - y1 + sub CX,DX ;; x2 - x1 + sub AX,DX ;; L - x1 + imul BX ;; (y2 - y1) * (L - x1) = q + idiv CX ;; q / (x2 - x1) + add AX,SI ;; y1 + q / (x2 - x1) + endm + +;----------------------------------------------------------------------------- +; The "overlap" macro. in: none +; out: none (look at Z flag) +; destroys AX,BX,CX +; usage: overlap contained,disjoint +; +; Compares the two rectangles: +; (Curr_X,Curr_Y) - (Stop_X,Stop_Y) and +; (Clip_left,Clip-top) - (Clip_right,Clip-bottom) +; and returns status on their intersection. +; +; If the Curr/Stop rectangle is totally contained in the clipping rectangle, +; jump to label "contained" with the Z flag on. If they are disjoint, jump +; to label "disjoint" with the Z flag off. Otherwise, they intersect, so +; fall through. Both jumps are short relative jumps. +;----------------------------------------------------------------------------- +overlap macro contained,disjoint + mov AX,Curr_X + mov BX,Curr_Y + call Encode_XY + mov CH,CL + mov AX,Stop_X + mov BX,Stop_Y + call Encode_XY + cmp CX,0 + jz contained ;;jump if Curr/Stop totally contained in CR + test CH,CL + jnz disjoint ;;jump if they're disjoint + endm + +;----------------------------------------------------------------------------- +; The "grafout" macro. in: none +; out: none +; destroys: AX,DX +; usage: grafout index,value +; +; For use in EGA mode. An EGA graphics-controller register is selected +; by writing "index" to port 3CEh. Then "value" is put into the register +; by writing it to port 3CFh. +;----------------------------------------------------------------------------- +grafout macro index,value +;; mov AL,index ;; select the register +;; mov DX,3CEh +;; out DX,AL +;; mov AL,value ;; write value to register +;; inc DX +;; out DX,AL +;; The above sequence of byte-width instructions can be +;; condensed into the below word-width instructions. +;; This gives roughly a 10% speed improvement. + mov AL,index + mov AH,value + mov DX,3CEh + out DX,AX + endm + +;----------------------------------------------------------------------------- +; The "seqout" macro. in: none +; out: none +; destroys: AX,DX +; usage: grafout index,value +; +; For use in EGA mode. An EGA sequencer register is selected +; by writing "index" to port 3C4h. Then "value" is put into the register +; by writing it to port 3C5h. +;----------------------------------------------------------------------------- +seqout macro index,value +;; This macro is similar to macro "grafout". + mov AL,index + mov AH,value + mov DX,3C4h + out DX,AX + endm + +;----------------------------------------------------------------------------- +; The "xy_lmap" macro. in: AX = X coordinate +; BX = Y coordinate +; out: AX = address of byte with pixel +; destroys: BX,CX,DX +; usage: xy_lmap nbytes +; +; Given pixel x,y on a linear graphics space, calculate the byte address +; offset that contains the pixel. AX,BX contain coordinates X,Y respectively. +; "Nbytes" are the number of 8-bit bytes per row of pixels. AX will contain +; the result address. The equation is: +; address = (y * nbytes) + (x / 8) +;----------------------------------------------------------------------------- +xy_lmap macro nbytes + xchg AX,BX + mov CX,nbytes + mul CX + shr BX,1 + shr BX,1 + shr BX,1 + add AX,BX + endm + + page +;----------------------------------------------------------------------------- + +TI_CRT equ 49h +IBM_CRT equ 10h +DOS_FUN equ 21h + + page +XGROUP group PROGX +DGROUP group DATA + + IFDEF XLI +; This stack is used for the standard XLI interface. However, a different +; stack (i.e. PCS's) is used during calls to a graphics driver. +STACK segment word stack 'STACK' +stackstart = $ + dw 16 dup (?) +stacksize = $ - stackstart +STACK ends + ENDIF ;XLI + +DATA segment byte public 'DATA' + assume DS:DGROUP +datastart = $ + +IFNDEF XLICOMB + + IFDEF COMBINED + public VID_MODE + extrn PC_MAKE:word + extrn char_hgt:word + extrn MAX_ROWS:byte + ENDIF ;COMBINED + + IFDEF VMXLI + public VID_MODE + extrn PC_MAKE:word + extrn char_hgt:word + extrn MAX_ROWS:byte + extrn sysint_table:dword + ENDIF ;VMXLI + +ENDIF ;XLICOMB + +;----------------------------------------------------------------------------- +; Some TIPC system constants. +;----------------------------------------------------------------------------- +X_MAX equ 720 ; Horizontal resolution +Y_MAX equ 300 ; Vertical resolution +Num_Colors equ 8 ; Number of colors displayable by TIPC +Bytes_per_Line equ 92 ; (720-displayed + extra word)/ 8-bits/byte +;----------------------------------------------------------------------------- +; Other constants +;----------------------------------------------------------------------------- +PIXEL_ON equ 1 ; mask to get rightmost bit of pixel color + +;----------------------------------------------------------------------------- +; These are the default values of the palette & misc. output latches. +;----------------------------------------------------------------------------- +DEF_RED equ 0AAh +DEF_GRN equ 0CCh +DEF_BLU equ 0F0h +TEXT_ON equ 040h ; This value is needed for bit-twiddling +TEXT_OFF equ 00h +YES_GRPH equ 0FFh +NO_GRAPH equ 00h +TRUE equ 0FFh +FALSE equ 00h +; locations +; (these equates corr. to DW's defined further below and exist +; for use by XPCINIT during TI video mode initialization) +RED_Pal equ 0DF01h +Misc_Lat equ 0DF82h +;----------------------------------------------------------------------------- +; Local variable storage. +;----------------------------------------------------------------------------- +IFDEF XLICOMB +PC_MAKE dw 0 ; Make of PC +CHAR_HGT dw 8 ; Character height +ENDIF + +VID_MODE dw 3,6 dup (0) ; Current video mode for TI (text & grafx on) + ; Also used for "exotic" video modes for IBM + ; when the MSBy is nonzero. + ; Current defined values for MSBy: + ; 1 = Hercules 720x348 mono graphics mode + IFNDEF VMXLI +Curr_X dw ? ; Current x-coordinate +Curr_Y dw ? ; Current y-coordinate +Stop_X dw ? ; Second endpoint x-coordinate for drawing +Stop_Y dw ? ; Second endpoint y-coordinate for drawing +clip_left dw ? ; Clipping rectangle (in screen coordinates) +clip_top dw ? +clip_right dw ? +clip_bottom dw ? +px dw ? ; Points to the independent variable +py dw ? ; Points to the dependent variable +Delta_X dw ? ; = Stop_X - Start_X +Delta_Y dw ? ; = Stop_Y - Start_Y +X_Dir dw ? ; -1,0,+1 : step of independent variable +Y_Dir dw ? ; -1,0,+1 : step of dependent variable +Xend dw ? ; End value of independent variable +Incr1 dw ? ; Step for using pnt below desired value +Incr2 dw ? ; Step for using pnt above desired value +GRAFIX_ON dw YES_GRPH ; TI Graphics are initially enabled +Box_Hite dw ? ; Box is this number of pixels high +Box_Width dw ? ; Number of bytes the box's width occupies +Left_Offset dw ? ; Byte offset into graphx planes of upper left box +Left_End dw ? ; Bit pattern of left end of solid box +Left_Side dw ? ; Bit pattern of left side of hollow box +Right_End dw ? ; Bit pattern of right end of solid box +Right_Side dw ? ; Bit pattern of right side of hollow box +Interior dw ? ; Bit pattern of interior of box +Fill_Fig db ? ; True if box is to be filled +func db ? ; EGA function 0 or 18h +f_code db 7 ; and/or/xor function +st_word dw ? ; start screen offset +st_bit dw ? ; start bit offset +ed_word dw ? ; ending word offset +ed_bit dw ? ; ending bit offset +w_p_row dw 40 ; # of words per row +b_p_wrds db 16 ; 16 bits per word +two dw 2 ; two +pix_c dw ? ; pixel color +gra_ram dw 0a000h ; EGA graphics ram address +y_val dw ? + + IFDEF TI +;----------------------------------------------------------------------------- +; Local constants storage. +;----------------------------------------------------------------------------- +X_Resolution dw X_MAX +Y_Resolution dw Y_MAX +Bits_per_Byte dw 8 +Color_Cycle db 8 +;----------------------------------------------------------------------------- +; Stored here will be the current values for the latches should +; the (ab)user decide to change them later with (set-palette!). +;----------------------------------------------------------------------------- +RED_Latch db DEF_RED +GRN_Latch db DEF_GRN +BLU_Latch db DEF_BLU + ENDIF ;TI + + IFDEF IBM +;----------------------------------------------------------------------------- +; A table of zeroes for clearing the palettes before a mode change on +; the EGA. +; A table of current values for the EGA colors. The table will be +; modified by each set-palette! command for the EGA. These values +; will be used to restore the colors after a mode change on the EGA. +;----------------------------------------------------------------------------- +clear_pal db 17 dup(0) +save_pal db 0,1,2,3,4,5,6,7,38h,39h,3ah,3bh,3ch,3dh,3eh,3fh,0 + ENDIF ;IBM + + IFDEF TI +;----------------------------------------------------------------------------- +; These are the segments for the three graphics bit-planes +; in the TIPC color graphics board. +;----------------------------------------------------------------------------- +Bank_A dw 0C000h +Bank_B dw 0C800h +Bank_C dw 0D000h +Misc_Latch dw 0DF82h +;----------------------------------------------------------------------------- +; These are the segments of the Red, Green, Blue palette latches. +;----------------------------------------------------------------------------- +RED_Palette dw 0DF01h +GRN_Palette dw 0DF02h +BLU_Palette dw 0DF03h +;----------------------------------------------------------------------------- +; Color to palette bits translation +;----------------------------------------------------------------------------- +Palette_Trans label byte + db 00000001b + db 00000010b + db 00010000b + db 00100000b + db 00000100b + db 00001000b + db 01000000b + db 10000000b + ENDIF ;TI + +;----------------------------------------------------------------------------- +; Single-bit-on words for setting individual pixels +;----------------------------------------------------------------------------- +Bit_Table label byte +; 01234567 (Pixel numbering - not bit numbering) + db 10000000b + db 01000000b + db 00100000b + db 00010000b + db 00001000b + db 00000100b + db 00000010b + db 00000001b +;----------------------------------------------------------------------------- +; Gradual bit filled bytes for the "left-side" of horizontal lines +;----------------------------------------------------------------------------- +Start_Line label byte +; 01234567 (Pixel numbering - not bit numbering) + db 11111111b + db 01111111b + db 00111111b + db 00011111b + db 00001111b + db 00000111b + db 00000011b + db 00000001b +;----------------------------------------------------------------------------- +; Gradual bit filled bytes for the "right-side" of horizontal lines +;----------------------------------------------------------------------------- +End_Line label byte +; 01234567 (Pixel numbering - not bit numbering) + db 10000000b + db 11000000b + db 11100000b + db 11110000b + db 11111000b + db 11111100b + db 11111110b + db 11111111b +;----------------------------------------------------------------------------- +; Clipping masks +;----------------------------------------------------------------------------- +; LTRB (left, top, right, bottom) +left_mask db 00001000b +top_mask db 00000100b +right_mask db 00000010b +bottom_mask db 00000001b + + IFDEF IBM +;----------------------------------------------------------------------------- +; Screen resolution table (for the different IBM video modes) +;----------------------------------------------------------------------------- +; The table contains the maximum *plottable* X,Y value for the mode. +Res_Table_IBM label word + dw 0,0 ;mode 0 not a graphics mode + dw 0,0 ;mode 1 not a graphics mode + dw 0,0 ;mode 2 not a graphics mode + dw 0,0 ;mode 3 not a graphics mode + dw 319,199 ;mode 4 is a graphics mode + dw 319,199 ;mode 5 is a graphics mode + dw 639,199 ;mode 6 is a graphics mode + dw 0,0 ;mode 7 not a graphics mode + dw 0,0 ;mode 8 PCjr only + dw 0,0 ;mode 9 PCjr only + dw 0,0 ;mode 10 PCjr only + dw 0,0 ;mode 11 EGA internal mode + dw 0,0 ;mode 12 EGA internal mode + dw 319,199 ;mode 13 is a graphics mode + dw 639,199 ;mode 14 is a graphics mode + dw 639,349 ;mode 15 is a graphics mode + dw 639,349 ;mode 16 is a graphics mode + dw 639,479 ;mode 17 VGA graphics mode + dw 639,479 ;mode 18 VGA graphics mode + dw 319,199 ;mode 19 VGA graphics mode + dw 1280,1280 ;---only for setting CR--- +Res_Table_IBM_Length equ ($-Res_Table_IBM)/4 + ENDIF ;IBM + + IFDEF HER +;----------------------------------------------------------------------------- +; Hercules +;----------------------------------------------------------------------------- +;;; --- Equates --- +her_mode_mask equ 00000010b ;mask to extract text/graphics bit +her_scrn_mask equ 00001000b ;mask to extract screen off/on bit +her_page_mask equ 10000000b ;mask to extract page0/page1 bit +her_index equ 3b4h ;port# of 6845 Index Reg; + ;this port + 1 is 6845 Data Reg +her_ctrl equ 3b8h ;port# of Display Mode Control Port +gr_blank equ 0h ;zero out graphics memory with this value +txt_blank equ 720h ;zero out text memory with this value +gr_size equ 4000h ;zero out this many words of graphic memory +txt_size equ 2000 ;zero out this many words of text memory +her_page0 equ 0B000h ;seg address screen memory page 0 +her_page1 equ 0B800h ;seg address screen memory page 1 +her_xmax equ 720 ;horizontal resolution +her_ymax equ 348 ;vertical resolution +;;; --- Constant data --- +; magic numbers for the 6845 CRT controller chip +; refer to Appendix 3, p. 21 of the Hercules manual +gtable db 35h,2dh,2eh,07h + db 5bh,02h,57h,57h + db 02h,03h,00h,00h +ttable db 61h,50h,52h,0fh + db 19h,06h,19h,19h + db 02h,0dh,0bh,0ch +;;; --- Variable data --- +her_disp db 0 ;state of text/graphics bit +her_page dw her_page0 ;address of active page + ENDIF ;HER + +;----------------------------------------------------------------------------- +; Jump table for graphit() based on op_code +;----------------------------------------------------------------------------- +OP_CODE dw SET_MODE + dw SETP + dw SET_PAL ; This used to be RESETP + dw LINE + dw GETP + dw VIDEO_MODE + dw BOX + dw FILLD_BX + dw SET_CLIP_RECT +table_len equ $ - OP_CODE + + IFDEF XLI +;----------------------------------------------------------------------------- +; XLI +;----------------------------------------------------------------------------- +;;; ----- Equates ----- +; offsets into the PSP +term_addr equ 0Ah +fb_addr equ 5Ch +;;; ----- Data structures ----- +; file block +file_block label word + dw 4252h + dw 10011b ;flags = sysint,0,0,16-bit,near + dw offset lookup_table, seg lookup_table + dw offset parm_block, seg parm_block +; reserved area of file block + dw 100h ;sysint# (256=%graphics) + dw offset graphit, seg graphit ;ISR entry point + dw 0,0,0,0,0 +; parameter block +parm_block label word ;not used + dw 0 +; lookup table +lookup_table label word + db '//' ;not used +; other needed values +psp dw ? ;PSP segment address +psize dw ? ;size of program in paragraphs +xwait dw 2 dup (?) ;XLI wait address +xbye dw 2 dup (?) ;XLI bye address + +datasize = $-datastart + ENDIF ;XLI + ENDIF ;VMXLI + +DATA ends +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +PROGX segment byte public 'PROGX' + assume CS:XGROUP,DS:DGROUP +progstart = $ + + IFNDEF VMXLI +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; name GRAPHIT -- Scheme interface to Rusty's graphics routines +; +; synopsis graphit(op, arg1, arg2, arg3, arg4, arg5, arg6); +; +; description call the appropriate graphics routine based on the "op" +; argument: +; 0 - (set-video-mode! mode) +; 1 - (setp x y color) +; 2 - (set-palette! curr-color-id new-color-id) +; 3 - (line x1 y1 x2 y2 color) +; 4 - (point x y) +; 5 - (get-video-mode) +; 6 - (box x-ul y-ul x-len y-len color) +; 7 - (filled_box x-ul y-ul x-len y-len color xor) +; 8 - (set-clipping-rectangle! left top right bottom) +; + + +; the following 2 structure definitions should be isomorphic to each other +gr_args struc + dw ? ; caller's DS + dw ? ; caller's BP + dd ? ; return address (far) +arg6 dw ? ; 7 argument 6 -- dbs 10/10/86 +arg5 dw ? ; 6 argument 5 +arg4 dw ? ; 5 argument 4 +arg3 dw ? ; 4 argument 3 +arg2 dw ? ; 3 argument 2 +arg1 dw ? ; 2 argument 1 +opcode dw ? ; 1 sub operation code +gr_args ends + +gr_values struc + dw ? ; caller's DS + dw ? ; caller's BP + dd ? ; return address (far) + dw ? ; 7 + dw ? ; 6 + dw ? ; 5 +gr_cols dw ? ; 4 # cols on physical screen +gr_rows dw ? ; 3 # rows on physical screen +gr_char_hgt dw ? ; 2 character-box height +gr_vmode dw ? ; 1 video mode +gr_values ends + + + public graphit +graphit proc far + push BP ; save caller's BP + push DS ; save caller's DS + IFDEF XLI + mov BX,data ; establish our data segment + mov DS,BX + ENDIF ;XLI + mov BP,SP ; establish our stack frame; + ; NOTE: this frame always appears on + ; PCS's stack, no matter how this + ; file is assembled + +; Load sub opcode + mov BX,[BP].opcode ; load sub operation code + add BX,BX ; adjust for index into jump table + cmp BX,table_len ; bad op_code? + jae bad_op + +; Call desired graphics function + call OP_CODE[BX] + jmp short gr_end + +bad_op: mov AX,-1 + +; Return to caller +gr_end: mov SP,BP ; dump arguments off TIPC's stack + pop DS ; restore caller's data segment + pop BP ; restore caller's BP + ret ; return to caller +graphit endp + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name SET_MODE - graphics initialize +; +; synopsis (set-video-mode! mode_number) +; +; description TIPC | IBM-PC +; MODE ACTION | MODE ACTION(same as AH=0,INT 10H) +; --------------------------+--------------------------- +; 0 Clear graphics | 0 40x25 BW 4 320x200 Col +; 1 Text Enable | 1 40x25 Color 5 320x200 BW +; 2 Graphics Enable | 2 80x25 BW 6 640x200 BW +; 3 Text & Graphics Ena | 3 80x25 Color +; +--------------------------- +; | EGA modes: +; | 13 320x200 16col 40x25 8x8cbox +; | 14 640x200 16col 80x25 8x8cbox +; | 15 640x350 4col 80x25 8x14cbox +; | 16 640x350 16col 80x25 8x14cbox +; +--------------------------- +; | VGA modes: +; | 17 640x480 2col +; | 18 640x480 16col +; | 19 320x200 256col +; +; returns nothing +; +SET_MODE proc near + push BP + push ES + mov AX,[BP].arg1 ; get mode-number + push AX ; save mode number for later + cmp ah,0 ; is high-order byte on? + jne spec_mode ; yes, jump; we have special cases + IFDEF COMBINED + cmp PC_MAKE,TIPC ; are we in TI mode? + jne ibm_mode ; no, jump; IBM + jmp ti_mode ; else TI + ENDIF ;COMBINED + IFDEF XLI + IFDEF TI + jmp ti_mode + ELSE + jmp ibm_mode + ENDIF ;TI + ENDIF ;XLI + +spec_mode label near + IFDEF HER + cmp ah,1 ; Hercules? + je her_mode + ENDIF ;HER + pop ax + mov ax,-1 ; unknown mode value + jmp err_ret + + IFDEF HER +her_mode label near +; On entry, AH = 1, AL = display-mode control port bits + call Reset_CR_Her ; reset clipping rectangle to full screen + mov ah,al + and ah,her_mode_mask + xor ah,her_disp ; did the mode change? + jz her_control ; no, jump + call reset_CRT_chip ; yes, reset 6845 CRT controller parameters +her_control: + mov dx,her_ctrl ; write bits to control port + out dx,al + mov bx,her_page0 ; determine address of active graphics page + test al,her_page_mask + jz her_5 + mov bx,her_page1 +her_5: mov her_page,bx ; save address of active graphics page + and al,her_mode_mask ; save state of text/graphics bit + mov her_disp,al + jnz her_10 ; if graphics mode, exit + pop dx ; reset MSBy vmode# on stack so get-video-mode + ; returns std IBM value rather than exotic vmode + xor dh,dh + push dx +her_10: jmp mode_end + ENDIF ;HER + + IFDEF IBM +ibm_mode label near + mov AH,12H ; Test for presence of EGA + mov BX,10H + int IBM_CRT ; IBM's video BIOS interrupt + cmp CX,0 ; Is there an EGA here ? + je ibm_cga ; Apparently not; assume CGA + push DS + pop ES + mov DX,offset clear_pal + mov AX,1002H ; Set EGA palettes to black for mode + int IBM_CRT ; change without screen flicker + pop AX + push AX + xor AH,AH ; Set video I/O mode (AH=0) (AL=MODE) + int IBM_CRT ; IBM's video BIOS interrupt + call Reset_CR_IBM ; reset clipping rectangle to full screen + + comment ~ ; commented out 11/6/87 - rb +; Initialize a delay loop + mov AH,2CH ; Get time + int DOS_FUN ; DOS function request + inc DH ; Add 1 second delay to start time + mov BX,DX ; Save the ending time + cmp BH,59 ; Test for 59 seconds (impossible limit) + jl tm_loop ; OK + mov BH,0 ; Set it = 0 to avoid a long delay +tm_loop: mov AH,2CH ; Get time + int DOS_FUN ; DOS function request + cmp DX,BX ; Enough time yet ? + jle tm_loop ; No, loop again + ~ ;end commented-out code +; + mov DX,offset save_pal + mov AX,1002H ; Set EGA palettes to saved colors + int IBM_CRT ; IBM's video BIOS interrupt + +IFNDEF XLICOMB + cmp [BP].arg1,18 ; Switching to mode 18 (VGA)? + jne i005 ; jump if not + mov MAX_ROWS,DEFAULT_VGA_ROWS ; reset number rows for ega + jmp i010 +i005: + mov MAX_ROWS,DEFAULT_NUM_ROWS ; reset default number rows +i010: +ENDIF + + jmp short mode_end + +ibm_cga label near + pop AX + push AX + xor AH,AH ; Set video I/O mode (AH=0) (AL=MODE) + int IBM_CRT ; IBM's video BIOS interrupt + call Reset_CR_IBM ; reset clipping rectangle to full screen + jmp short mode_end + ENDIF ;IBM + + IFDEF TI +ti_mode: call Reset_CR_TI ; reset clipping rectangle to full screen + cmp AL,0 ; Clear TI graphics and re-init palette + je clr_grfx1 + cmp AL,1 ; Turn off Graphics and Text on + je textonly1 + cmp AL,2 ; Turn on Graphics and Text off + je grfxonly1 + cmp AL,3 ; Turn on both Graphics and Text + je all_on1 + pop AX + xor AX,AX ; Bad op-code + not AX ; AX = -1 + jmp short err_ret + ENDIF ;TI + +mode_end: pop AX + mov VID_MODE,AX ; Save VID-MODE for (get-video-mode)[TI-only] +; for the individual drivers, build up return values on stack + IFDEF XLI + int 3 + mov [BP].gr_vmode,AX ; video mode + mov [BP].gr_char_hgt,8 ; character height + cmp AX,14 + jle mode_10 ; CGA, jump + mov [BP].gr_char_hgt,14 +mode_10: + cmp AX,18 ; VGA mode 18? + jne mode_12 ; no, jump + mov [BP].gr_char_hgt,16 ;vga mode 18 character height + mov [BP].gr_rows,DEFAULT_VGA_ROWS ;#rows on screen (used for pro) + mov [BP].gr_cols,DEFAULT_NUM_COLS ;#cols on screen + jmp mode_13 +mode_12: + mov [BP].gr_rows,DEFAULT_NUM_ROWS ;#rows on screen + mov [BP].gr_cols,DEFAULT_NUM_COLS ;#cols on screen +mode_13: + ENDIF ;XLI +; else return values directly inside VM + IFDEF COMBINED + mov char_hgt,8 ;default char height = 8 + cmp vid_mode,14 ;mode 14 or less? + jle err_ret ; yes, return + mov char_hgt,14 ;default char height = 14 + cmp vid_mode,18 ;mode 18? + jl err_ret ; no, return + mov char_hgt,16 ; yes, char height = 16 + ENDIF ;COMBINED + xor AX,AX ; Return something nice + +err_ret: pop ES ; Get the heck outta here + pop BP + ret + + IFDEF TI +clr_grfx1: jmp short clr_grfx ; relative jumps not long enough +grfxonly1: jmp short grfxonly +textonly1: jmp short textonly +all_on1: jmp short all_on + +clr_grfx: mov AH,14h ; Clear graphics planes + int TI_CRT ; Send command to CRT device driver + mov RED_Latch,DEF_RED ; Reset palettes to default values + mov GRN_Latch,DEF_GRN + mov BLU_Latch,DEF_BLU + cmp byte ptr GRAFIX_ON,YES_GRPH + jne short mode_end + mov AL,RED_Latch ; if graphics are enabled reset the palettes + mov BL,GRN_Latch + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + jmp mode_end + +grfxonly label near + mov AL,RED_Latch + mov BL,GRN_Latch + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + mov AL,TEXT_OFF + call txt_set ; Turn text off + jmp mode_end + +textonly label near + xor AL,AL + mov BL,AL + mov CL,AL + mov DL,NO_GRAPH + call pal_set ; Set the graphics palettes off + mov AL,TEXT_ON + call txt_set ; Turn text on + jmp mode_end + +all_on label near + mov AL,RED_Latch + mov BL,GRN_Latch + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + mov AL,TEXT_ON + call txt_set ; Turn text on + jmp mode_end + +pal_set label near + push BP + xor BP,BP ; Zero offset from palette segments + mov ES,RED_Palette + mov byte ptr ES:[BP],AL ; Set red palette + mov byte ptr ES:[BP]+16,BL ; Set green palette + mov byte ptr ES:[BP]+32,CL ; Set blue palette + mov byte ptr GRAFIX_ON,DL ; if graphics are on or not + pop BP + ret + +txt_set label near + push BP + xor BP,BP + mov ES,Misc_Latch + mov byte ptr ES:[BP],AL + pop BP + ret + ENDIF ;TI + +SET_MODE endp + + IFDEF HER +reset_CRT_chip proc near + +; This routine resets the Hercules 6845 CRT controller whenever +; switching between text and graphics modes. +; The screen memory is also cleared. +; +; On entry: AL is the display mode control word. +; Destroys: AH,BX..DI +; On exit: AL is unaltered +; ES is address of active screen page + + test al,her_mode_mask ;turn on graphics mode? + jz rcc_txt_mode ;no, jump +; turn on graphics mode + mov si,offset gtable + mov bx,gr_blank + mov cx,gr_size + jmp rcc_init +; turn on text mode +rcc_txt_mode: + mov si,offset ttable + mov bx,txt_blank + mov cx,txt_size +rcc_init: +; at this point: +; AL = control byte +; BX = blank value +; CX = # 16-bit words to blank out +; SI = @ parameter table + push ax ;tempsave ctrl word + push ax + push cx ;tempsave #words to clear + mov ah,al + and ah,her_page_mask+her_mode_mask ;turn off screen + ;leave mode, page alone + xchg ah,al + mov dx,her_ctrl + out dx,al ;output it + mov ax,ds + mov es,ax ;ES:SI points to parameter table + mov dx,her_index ;set port# to 6845 Index Register + mov cx,12 ;we're going to output 12 parameters + xor ah,ah ;starting from register zero +rcc_parms: mov al,ah ;AL is register# + out dx,al ;output it + inc dx ;inc port# to 6845 Data Register + lodsb ;get next parameter value + out dx,al ;and output it + inc ah ;inc to next register + dec dx ;dec port# back to Index Register + loop rcc_parms + pop cx ;restore blank count + pop ax ;restore ctrl word + test ax,her_page_mask ;clear page 1? + jnz rcc_pg1 ;yes, jump + mov ax,her_page0 ;get address of screen page 0 + jmp short rcc_clr +rcc_pg1: mov ax,her_page1 ;get address of screen page 1 +rcc_clr: cld + mov es,ax + xor di,di ;ES:DI points into screen memory + mov ax,bx ;AX is blank value + rep stosw ;clear screen memory + pop ax ;restore ctrl word + ret + +reset_CRT_chip endp + ENDIF ;HER + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name SETP -- turn on a pixel at the given coordinates with +; the specified color. +; +; synopsis (setp x y color) +; +; description Turn on the pixel at (x,y) [origin at upper left] with +; one of the colors specified by 'color'. +; Point clipping is done. +; +; returns nothing +; +SETP proc near + push BP + push DI + push ES +; + mov AX,[BP].arg1 ; Get `x' + mov BX,[BP].arg2 ; Get `y' +; call Fix_XY ; Force x and y into their proper ranges + call Encode_XY ; Encode point's visibility + cmp CL,0 ; is it visible? + jnz Set_exit ; no, jump + mov CX,[BP].arg6 ; xor code + mov f_code,CL + mov CX,[BP].arg3 ; Get `color' + call LCL_SETP ; Display pixel +Set_exit: xor AX,AX ; Return code of zero + pop ES + pop DI + pop BP + ret +SETP endp ; End of SETP(,,) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name SET_PAL -- Modify the current palette according to PC_MAKE +; +; synopsis (set-palette! curr-color-id new-color-id) +; +; description If PC_MAKE == TIPC then set-palette twiddles the TIPC +; graphics palette latches according to the colors specified. +; +; If PC_MAKE == [PC,XT,jr,AT] then use the IBM video I/O +; interrupt (10h), function 11, set color palette; +; or function 16, set palette registers if EGA is present. +; +; returns nothing +; +SET_PAL proc near + push BP + push ES + mov BX,[BP].arg1 ; Get current-color-id + mov CX,[BP].arg2 ; Get new-color-id +; **** WARNING **** Fix the IBM side of this swapping of A,BX <=> B,CX +; + IFDEF COMBINED + cmp PC_MAKE,TIPC + jne ibm_pal + ENDIF ;COMBINED + + IFDEF TI + and BX,7 ; use only lower three bits + mov AL,Palette_Trans[BX] ; convert BL to 1-in-8 bits + mov AH,AL + not AH ; AH = 7-in-8 mask + mov BL,RED_Latch + call twiddle + mov RED_Latch,BL + mov BL,BLU_Latch + call twiddle + mov BLU_Latch,BL + mov BL,GRN_Latch + call twiddle + mov GRN_Latch,BL + cmp byte ptr GRAFIX_ON,YES_GRPH ; are graphics enabled? + jne pal_ret + mov AL,RED_Latch ; if yes, then update display palettes + mov CL,BLU_Latch + mov DL,YES_GRPH + call pal_set ; Set the graphics palettes on + jmp short pal_ret + +twiddle label near + sar CL,1 ; Do we turn the bit on or off + jnc turn_off + or BL,AL ; Turn it on + ret +turn_off: and BL,AH ; Turn it off + ret + ENDIF ;TI + + IFDEF IBM +ibm_pal: mov AH,15 ; Get current video mode + int IBM_CRT ; IBM video I/O interrupt + cmp AL,4 ; Is mode = 4 ? + jne pal_ega ; No, jump + ; CGA palette + mov BH,BL ; BH = palette color id being set + mov BL,CL ; BL = color value + mov AH,11 ; Set CGA color palette + int IBM_CRT ; IBM video I/O interrupt + jmp short pal_ret + ; EGA palette +pal_ega: mov BH,CL ; BL = palette color id being set + ; BH = color value + cmp BL,16 ; Is color id reasonable ? + jge pal_ret ; No, forget it + mov AX,1000H ; Set EGA color palette + int IBM_CRT ; IBM video I/O interrupt + mov BH,0 ; Use palette color id (BL) as index + mov DS:save_pal[BX],CL ; Save color value in palette table + ENDIF ;IBM + +pal_ret: xor AX,AX ; Return code of zero + pop ES + pop BP + ret +SET_PAL endp ; End of (set-palette!...) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name VIDEO_MODE - return the current video mode +; +; synopsis (get-video-mode) +; +; description Returns the video mode number for the appropriate PC. +; +; returns video mode number +; + public VIDEO_MODE +VIDEO_MODE proc near + IFDEF HER + cmp byte ptr VID_MODE+1,0 ;is high-order byte zero? + jne get_ti_m ;no, exotic video mode, return that instead + ENDIF ;HER +; at this point, high-order byte of video mode is zero + IFDEF COMBINED + cmp PC_MAKE,TIPC + je get_ti_m + ENDIF ;COMBINED + IFDEF IBM + mov AH,15 ; IBM's get current video state + int IBM_CRT + cbw ; Convert to full word. + ret + ENDIF ;IBM +; used by TI or "exotic" video modes for IBM +get_ti_m: mov AX,VID_MODE ; This was squirreled away by SET_MODE (TI) + ret +VIDEO_MODE endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name LINE -- draw a line between the two sets of coordinates +; given with the specified color. +; +; synopsis (line x1 y1 x2 y2 color) +; +; description Draw a line between (x1,y1) and (x2,y2) with one of the 8 +; colors specified by 'color'. The line is clipped. +; +; This routine is based upon Bresenham's Line Algorithm +; from page 435 in "Fundamentals of Interactive Computer +; Graphics" by Foley and Van Dam. +; +; The clipping algorithm is Cohen and Sutherland's. +; See pages 65-67, "Principles of Interactive Computer Graphics" +; (2nd edition) by Newman and Sproull. +; +; returns nothing +; +LINE proc near + +; Look for horizontal or vertical lines first. If so, we can use BOX +; to output them a byte of pixels at a time rather than just one pixel +; at a time, with a significant speedup (even clipping is faster). + + mov AX,[BP].arg1 ; is line horizontal? + cmp AX,[BP].arg3 + jne line_10 ; no, jump + jmp BOX ; yes, use BOX, it's faster +line_10: mov AX,[BP].arg2 ; is line vertical? + cmp AX,[BP].arg4 + jne line_20 ; no, jump + jmp BOX ; yes, use BOX, it's faster + +line_20: push DI + push SI + push ES + +; Clip line + + mov AX,[BP].arg1 ; Get x1 + mov BX,[BP].arg2 ; Get y1 + mov CX,[BP].arg3 ; Get x2 + mov DX,[BP].arg4 ; Get y2 + cmp AX,CX ; is x1 <= x2? + jle x1_first ; yes, jump + ; always draw from p1 to p2; otherwise the same line drawn + ; in the opposite direction may not exactly overlay it + xchg AX,CX ; no, interchange the two points + xchg BX,DX +x1_first: mov Curr_X,AX + mov Curr_Y,BX + mov Stop_X,CX + mov Stop_Y,DX + call Clip_line + jz Do_line ; jump if line is visible + jmp Line_exit ; jump if line is invisible + +; Line drawing proper + +Do_line: mov px,offset Curr_X ; px = address of Curr_X + mov py,offset Curr_y ; py = address of Curr_Y +; + mov BX,[BP].arg6 ; get xored or not + mov f_code,BL +; + mov AX,Stop_X + mov BX,Stop_Y + mov Xend,AX ; Independent var's end-value unless swapped + + sub BX,Curr_Y ; Delta_Y = y2 - y1 + mov Delta_Y,BX + sub AX,Curr_X ; Delta_X = x2 - x1 + mov Delta_X,AX + xchg AX,BX ; Put Delta_Y into ax; Delta_X into bx +; + jz Swap_Things ; Is Delta_X == 0 ? + cwd ; Ready dx for division + idiv BX + neg AX + jge Test_Slope + neg AX ; slope = ax = ABS(INT(dy/dx)) +Test_Slope label near + cmp AX,1 ; IF slope >= 1 THEN + jl Get_X_Increment +; +Swap_Things label near + xchg Delta_Y,BX + mov Delta_X,BX ; swap(dx,dy) + mov CX,px + xchg py,CX + mov px,CX ; swap(px,py) + mov CX,Stop_Y + mov Xend,CX ; Xend = Stop_Y since variables' + ; dependence was swapped. + ; ENDIF +Get_X_Increment label near + or BX,BX ; X_Dir = sgn(Delta_X) + jz Save_X_Dir ; IF it's zero THEN we're done + mov BX,1 ; ELSE force bx = 1 + jg Save_X_Dir ; IF Delta_X was < zero THEN + neg BX ; bx = -1 +Save_X_Dir label near + mov X_Dir,BX +; + mov BX,Delta_Y + or BX,BX ; Y_Dir = sgn(Delta_Y) + jz Save_Y_Dir ; IF it's zero THEN we're done + mov BX,1 ; ELSE force bx = 1 + jg Save_Y_Dir ; IF Delta_X was < zero THEN + neg BX ; bx = -1 +Save_Y_Dir label near + mov Y_Dir,BX +; + mov AX,Delta_X ; Delta_X = ABS(Delta_X) + neg AX + jge Save_ABS_Dx + neg AX +Save_ABS_Dx label near + mov Delta_X,AX +; + mov BX,Delta_Y ; Delta_Y = ABS(Delta_Y) + neg BX + jge Save_ABS_Dy + neg BX +Save_ABS_Dy label near + mov Delta_Y,BX +; + shl BX,1 + mov Incr1,BX ; Incr1 = Delta_Y * 2 + sub BX,AX + push BX ; d = Delta_Y * 2 - Delta_X + sub BX,AX + mov incr2,BX ; Incr2 = (Delta_Y - Delta_X) * 2 +; + mov CX,[BP].arg5 ; Push `color' for call to SETP + mov BX,Curr_Y ; Push `y' + mov AX,Curr_X ; Push `x' + call LCL_SETP ; Plot beginning point +; + mov DI,px ; Get pointer to independent variable + mov SI,py ; Get pointer to dependent variable + mov AX,X_Dir + mov BX,Y_Dir + mov CX,Xend + pop DX ; get D from stack +; +While label near + cmp CX,DS:[DI] ; While (px->start != xend) { + je While_End + add DS:[DI],AX ; Px->start += X_Dir + or DX,DX ; IF (D < 0) THEN + jge Inc_Dependent + add DX,Incr1 ; D += Incr1 + jmp short End_If +Inc_Dependent label near ; ELSE + add [SI],BX ; Py->start += Y_Dir + add DX,Incr2 ; D += Incr2 +End_If label near ; ENDIF + push AX ; Save X_Dir + push BX ; Save Y_Dir + push CX ; Save Xend + push DX ; Save D + push SI + push DI +; + mov CX,[BP].arg5 ; Push `color' for call to SETP + mov BX,Curr_Y ; Push `y' + mov AX,Curr_X ; Push `x' + call LCL_SETP ; Plot beginning point +; + pop DI + pop SI + pop DX + pop CX + pop BX + pop AX + jmp short While +; +While_End label near +Line_exit label near + xor AX,AX ; Return code of zero + pop ES + pop SI + pop DI + ret +LINE endp ; End of LINE(,,,,) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name GETP -- return the attribute (color) at the specified +; coordinates. +; +; synopsis (getp x y) +; +; description Return the pixel value (0 - 7) at the coordinates given +; as arguments. The coordinates are clipped. +; +; returns An unsigned integer in the range 0 to 7 , inclusive, +; if the pixel lies inside the clipping rectangle. +; The first bit-plane starting at 0C0000h will have its +; bit represented by the lsb of the returned word. The +; last bit-plane starting at 0D0000h will have its bit +; represented by bit number 2 (lsb = bit 0) of the returned +; word. +; +; If the pixel lies outside the clipping rectangle, return -1. +; +GETP proc near + push BP + push DI + push ES +; + mov AX,[BP].arg1 ; Get `x' + mov BX,[BP].arg2 ; Get `y' +; call Fix_XY ; Force x and y into their proper ranges + call Encode_XY ; Encode point's visibility in the CR + cmp CL,0 ; is point visible in the CR? + mov AX,-1 + jne IBM_Ret_Clr ; no, jump (return -1 in AX) + mov AX,[BP].arg1 ; restore AX to 'x' + + IFDEF HER + cmp byte ptr VID_MODE+1,1 ;Hercules? + je her_getp + ENDIF ;HER + + IFDEF COMBINED + cmp PC_MAKE,TIPC + je ti_getp + ENDIF ;COMBINED +; + IFDEF IBM + mov dx,bx ; Do it the IBM way (ugh!) + mov cx,ax + mov ah,13 + int IBM_CRT ; IBM Video BIOS + xor ah,ah ; Color is in AL + mov dx,ax + jmp short IBM_Ret_Clr + ENDIF ;IBM + + IFDEF TI +ti_getp label near + call GM_Offset ; Convert (x,y) to linear offset +; +; Read the specified bit in each of the graphics memory banks. +; + xor DX,DX ; Clear value to be returned + mov ES,Bank_C ; Get segment of 3rd bank + mov BH,ES:[DI] ; Copy the selected byte in graphics memory + and BH,AH ; Was the bit on ? + jz short Test_Bank_B + inc DX +; +Test_Bank_B label near + shl DX,1 + mov BX,ES + sub BH,08h + mov ES,BX + mov BH,ES:[DI] ; Copy the selected byte in graphics memory + and BH,AH ; Was the bit on ? + jz short Test_Bank_A + inc DX +; +Test_Bank_A label near + shl DX,1 + mov BX,ES + sub BH,08h + mov ES,BX + mov BH,ES:[DI] ; Copy the selected byte in graphics memory + and BH,AH ; Was the bit on ? + jz short Return_Color + inc DX +; +Return_Color label near + mov AX,DX ; Put returning value into ax + ENDIF ;TI + +IBM_Ret_Clr label near + pop ES + pop DI + pop BP + ret + + IFDEF HER +her_getp: call Her_GM_Offset + mov BL,Bit_Table[BX] + mov ES,her_page + xor AX,AX + test BL,ES:[DI] + jz IBM_Ret_Clr ; return 0 in AX if pixel off + inc AX + jmp IBM_Ret_Clr ; else return 1 + ENDIF ;HER + +GETP endp ; End of GETP(,) +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +; Encode_XY in: AX=X, BX=Y +; out: CL=code +; destroyed: CL +; +; Encode X,Y into a 4-bit code indicating its visibility in the clipping rectangle. +; The code is returned in CL: CL =0: point is visible +; CL<>0: point is invisible. +;----------------------------------------------------------------------------- +Encode_XY proc near + mov CL,0 ; clear CL; code is constructed here + cmp AX,clip_left ; x >= clip_left? + jge Enc_1 ; yes, jump + or CL,left_mask ; no, set bit +Enc_1: cmp BX,clip_top ; y >= clip_top? + jge Enc_2 ; yes, jump + or CL,top_mask ; no, set bit +Enc_2: cmp AX,clip_right ; x <= clip_right? + jle Enc_3 ; yes, jump + or CL,right_mask ; no, set bit +Enc_3: cmp BX,clip_bottom ; y <= clip_bottom? + jle Enc_4 ; yes, jump + or CL,bottom_mask ; no, set bit +Enc_4: ret +Encode_XY endp + + page +;----------------------------------------------------------------------------- +; Clip_line in: none +; out: none (Z flag) +; destroyed: AX,BX,CX,DX,SI,DI +; +; The line between (Curr_X, Curr_Y) and (Stop_X, Stop_Y) is clipped. +; The two points' coordinates are possibly modified during the process. +; On exit: Z=0 if line is visible (onscreen); the final coordinates +; are in the Curr and Stop memory locations +; Z=1 if line is invisible (offscreen) +;----------------------------------------------------------------------------- +Clip_line proc + mov DI,offset Stop_X + overlap Cli_exit,Cli_exit ; if line's extents rectangle lies wholly + ; inside or wholly outside clipping rectangle, + ; exit immediately + + jmp short Cli_loop ; else start clipping + +; At this point AX=new X and BX=new Y. +; (Note this is executed *after* the loop. It's rearranged to +; get all the relative branches within range.) + +Cli_join: + mov [DI],AX ; store X back into memory + mov [DI+2],BX ; ditto for Y + pop CX ; restore codes + call Encode_XY ; get code for new X and Y + + cmp CX,0 ; is combined code zero? + jz Cli_exit ; yes, jump; line totally visible at last + test CH,CL ; do any encoded bits line up? + jz Cli_loop ; no, jump; some part of line is visible. + ; if fall thru, line was invisible after all +Cli_exit: ret + +; We have to clip the line. + +Cli_loop: cmp CL,0 ; is this point visible? + jnz Cli_1 ; no, jump + xchg CH,CL ; yes, go work on other point + sub DI,4 ; set pointer to other point +Cli_1: push CX ; tempsave the codes + test CL,left_mask ; is point off left side? + jz Cli_2 ; no, jump + ; The endpoint is to the left of the clipping rectangle. + intersect clip_left,Stop_Y,Stop_X,Curr_X,Curr_Y + mov BX,AX ; new Y + mov AX,clip_left ; new X + jmp Cli_join +Cli_2: test CL,top_mask ; is point off top side? + jz Cli_3 ; no, jump + ; The endpoint is above the top of the clipping rectangle. + intersect clip_top,Stop_X,Stop_Y,Curr_Y,Curr_X + ; AX contains new X already + mov BX,clip_top ; new Y + jmp Cli_join +Cli_3: test CL,right_mask ; is point off right side? + jz Cli_4 ; no, jump + ; The endpoint is to the right of the clipping rectangle. + intersect clip_right,Stop_Y,Stop_X,Curr_X,Curr_Y + mov BX,AX ; new Y + mov AX,clip_right ; new X + jmp Cli_join +Cli_4: ; no need for more tests + ; The endpoint is below the bottom of the clipping rectangle. + intersect clip_bottom,Stop_X,Stop_Y,Curr_Y,Curr_X + ; AX contains new X already + mov BX,clip_bottom ; new Y + jmp Cli_join + +Clip_line endp + + page +;----------------------------------------------------------------------------- +; Clip_box in: none +; out: none +; destroyed: AX +; +; The box with corners (Curr_X, Curr_Y) and (Stop_X, Stop_Y) is clipped. +; (The corners should be (left,top) and (right,bottom) respectively.) +; The two points' coordinates are possibly modified during the process. +;----------------------------------------------------------------------------- +Clip_box proc + mov AX,clip_left + cmp Curr_X,AX + jge CB_1 + mov Curr_X,AX +CB_1: mov AX,clip_top + cmp Curr_Y,AX + jge CB_2 + mov Curr_Y,AX +CB_2: mov AX,clip_right + cmp Stop_X,AX + jle CB_3 + mov Stop_X,AX +CB_3: mov AX,clip_bottom + cmp Stop_Y,AX + jle CB_4 + mov Stop_Y,AX +CB_4: ret +Clip_box endp + + page +;----------------------------------------------------------------------------- + + comment ~ + +; NOTE: This routine is no longer called. Clipping is done instead. - rb + +Fix_XY proc near ; Force x and y into their proper values + cmp PC_MAKE,TIPC + jne ibm_dsnt ; IBM doesn't do range checking, Y should I? + ; On IBM, the ranges will vary with the mode + ; On entry ax = `x', bx = `y' + ; On exit ax = ax MOD 720, bx = bx MOD 300 + ; cx & dx = + ; Get `x';fix to proper range (already in ax) + xor DX,DX ; Clear DX - unsigned dbl-word + div X_Resolution ; ax = INT(x / 720), dx = (x MOD 720) + mov CX,DX ; I want the MOD function.... + ; + mov AX,BX ; Get `y' and fix to proper range + xor DX,DX ; Clear DX - unsigned dbl-word + div Y_Resolution ; ax = INT(y / 300), dx = (y MOD 300) + ; I want the MOD function.... + mov BX,DX + mov AX,CX ; Put `x' back +ibm_dsnt: ret +Fix_XY endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + ~ ;end comment + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + IFDEF TI +GM_Offset proc near +; +; Determine which word needs modifying and which bit to set. +; byte_offset = (Curr_Y * 736-bits/y_pixel * 1-byte/8-bits) +; + INT(Curr_X * 1-byte/8-x_pixels) +; bit-in-byte = Curr_X MOD 8 [0-msb, 8-lsb in byte] +; + ; On entry ax = `x', bx = `y' + ; On exit + ; ah = bit-in-byte, bx = + ; cx = , dx = + ; di = byte-addr into graphics memory + ; ** NOTE: this address is + ; byte-swapped, e.g. pixel 0 is + ; in byte 1 and pixel 8 is in + ; byte 0. To do address arithmetic, + ; the byte-swapping must first + ; be removed. ** + xchg AX,BX ; now ax = `y' & bx = `x' +; neg AX ; Translate y=0 to bottom of screen +; add AX,Y_MAX-1 ; y_new = 299 - (y_old MOD 300) +; mul Bytes_per_Line ; Curr_Y * 736/8-bytes/y_pixel + shl AX,1 ; 2-clocks + shl AX,1 ; 2-clocks + mov DX,AX ; 2-clocks + shl AX,1 ; 2-clocks + add AX,DX ; 3-clocks + neg DX ; 3-clocks + shl AX,1 ; 2-clocks + shl AX,1 ; 2-clocks + shl AX,1 ; 2-clocks + add AX,DX ; 3-clocks + ; TOTAL = 23-clocks + ; MUL = (128-143)+EA + xchg AX,BX ; ........save partial sum + ; and get `x' into accumulator +; xor DX,DX ; Clear DX - unsigned dbl-word +; div Bits_per_Byte ; ax = word offset from beginning of line + ; dx = bit-in-byte (x MOD 8) + mov DX,7 ; mask all bits 'cept lower 3 + ; 4-clocks + and DX,AX ; 3-clocks + shr AX,1 ; 2-clocks + shr AX,1 ; 2-clocks + shr AX,1 ; 2-clocks + ; TOTAL = 13-clocks + ; DIV = (154-172)+EA + add AX,BX ; Ax = byte # offset into graphics bank + xor AL,1 ; fix byte offset address to jive with + ; backward byte ordering + mov DI,AX ; move for addressing graphics memory + mov BX,DX ; Saves on number of memory accesses + mov AH,Bit_Table[bx] ; Ax = bit-pattern + mov AL,AH + not AL ; al = NOT ah - for turning bits off + ret +GM_Offset endp + ENDIF ;TI + + IFDEF HER +Her_GM_Offset proc near + +; Determine the byte address and bit-in-byte of pixel to be altered. +; For the Hercules mono graphics card, the equations are: +; byte address = (2000h * (y mod 4)) + (90 * int(y/4)) + int(x/8) +; bit-in-byte = 7 - (x mod 8) +; Therefore, pixel 0,0 appears in bit 7, and +; pixels are stored left to right in a byte. +; +; On entry: AX = X coordinate +; BX = Y coordinate +; Destroyed: DX,SI +; On exit: DI = byte address +; AH = bit mask corr. to bit-in-byte +; AL = NOT AH +; BX = bit-in-byte +; CX = (preserved) + + push CX ; tempsave CX + mov CX,AX + and CX,00000111b ; get bit-in-byte + mov SI,CX + mov DI,CX + mov CL,Bit_Table[DI] ; get bit mask + mov DI,CX ; and stow it away in DI + mov CX,AX + shr CX,1 + shr CX,1 + shr CX,1 ; CX = int(x/8) = qc + mov ax,bx + and ax,00000011b ; AX = y mod 4 +; 3 ROR's is same as multiplying by 2000h. +; mov dx,2000h +; mul dx ; AX = 2000h * (y mod 4) = qa + ror ax,1 + ror ax,1 + ror ax,1 + xchg ax,bx ; BX = qa + shr ax,1 + shr ax,1 ; AX = int(y/4) + mov dx,90 + mul dx ; AX = 90 * int(y/4) = qb + add ax,bx ; AX = qa + qb + add ax,cx ; AX = qa + qb + qc = byte addr + xchg ax,di ; DI is byte addr + mov ah,al ; AH is bit mask + not al ; AL is NOT AH + mov bx,si ; BX is bit-in-byte + pop cx ; restore CX + ret +Her_GM_Offset endp + ENDIF ;HER + + IFDEF IBM +EGA_GM_Offset proc near + +; Determine the byte address and bit-in-byte of pixel to be altered. +; The IBM EGA graphics memory is linear. +; +; On entry: AX = X coordinate +; BX = Y coordinate +; Destroyed: DX +; On exit: DI = byte address +; AH = bit mask corr. to bit-in-byte +; AL = NOT AH +; BX = bit-in-byte +; CX = (preserved) + + push CX ; tempsave CX + push AX ; tempsave X coordinate + xy_lmap 80 ; Get addr of byte containing x,y + mov DI,AX ; DI is byte address + pop BX ; restore X coordinate + and BX,7 ; BX is bit-in-byte + mov AL,Bit_Table[BX] + mov AH,AL ; AH is bit mask + not AL ; AL is NOT AH + pop CX ; restore CX + ret +EGA_GM_Offset endp + ENDIF ;IBM + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; + public LCL_SETP +LCL_SETP proc near + +; On entry: +; AX = X coordinate +; BX = Y coordinate +; CX = color +; Destroys: AX..DI,ES +; Returns: nothing + + IFDEF HER + cmp byte ptr VID_MODE+1,1 ;Hercules? + je her_setp ;yes, jump + ENDIF ;HER + + IFDEF COMBINED + cmp PC_MAKE,TIPC + je ti_setp + jmp ibm_setp + ENDIF ;COMBINED + + + IFDEF HER +her_setp label near + call Her_GM_Offset ; convert (x,y) to byte offset + mov ES,her_page ; get address of active page + call set_pixel2 ; and tell that bit whose boss + ret + ENDIF ;HER + + IFDEF TI +ti_setp label near + call GM_Offset ; Convert (x,y) to byte offset +; +; Determine which graphics memory banks get their bits twiddled. +; + +Set_Byte label near + mov ES,Bank_A ; Get segment of 1st bank + call set_pixel2 +; + shr CX,1 + mov ES,Bank_B + call set_pixel2 ; Turn on the proper bit +; + shr CX,1 + mov ES,Bank_C + call set_pixel2 ; Turn on the proper bit + ret + ENDIF ;TI +; +;Quit_n_Quit label near ; Save the current X & Y and return +; ret + + IFDEF IBM +ibm_setp: + cmp VID_MODE,14 + jge ibm_egap +; CGA point plot + cmp f_code,1 + jne ibm_set1 + or CL,080h ; set xor flag on +ibm_set1: mov DX,BX ; Move arguments around for IBM + xchg CX,AX + xor BH,BH ; video plane + mov AH,12 ; write dot + int IBM_CRT + ret +; EGA point plot +ibm_egap: + push AX ; tempsave X coordinate + seqout 2,0Fh ; enable sequencer Map Mask register + mov CH,f_code + or CH,CH ; do xor? + jz ibm_ega1 ; no, jump + mov CH,18h ; yes +ibm_ega1: grafout 3,CH ; (Function Register) + mov AX,0A000h ; EGA screen memory starts at A000:0 + mov ES,AX ; ES:DI will be pointer into screen memory + grafout 0,CL ; (Set/Reset Register) + grafout 1,0Fh ; (Enable Set/Reset Register) + pop AX ; restore X coordinate + push AX + xy_lmap 80 ; Get addr of byte containing x,y + mov DI,AX ; DI is address of byte in screen memory + ; that contains the pixel + pop BX ; restore X coordinate + and BX,07h ; do X mod 8 + mov BL,Bit_Table[BX] ; BL is mask for the pixel to change + grafout 8,BL ; (Bit Mask Register) + mov AH,ES:[DI] ; latch screen memory byte: in + mov ES:[DI],AH ; and out + grafout 0,0 ; get EGA registers back to normal + grafout 1,0 + grafout 3,0 + grafout 8,0FFh + ret + ENDIF ;IBM + +LCL_SETP endp + + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name BOX -- Draw a box in the graphics plane with the +; specified color. +; +; synopsis (box x-ul y-ul x-lr y-lr color) +; +; description Draw a box with graphics (not text characters). The +; upper left-hand corner is specified by (x-ul,y-ul) +; and the lower right-hand is specified by (x-lr,y-lr). +; Color indicates the pixel values that will make up the +; box. The interior will not be filled nor modified +; in any way. The box is clipped. +; Edges that are clipped are "shrunk inwards" to fit +; snug against the corresponding edges of the clipping +; rectangle. The result is another box and not just +; some line segments as you'd might expect. +; +; returns nothing +; +BOX proc near + mov Fill_Fig,FALSE ; This box ain't getting filled +BOX_2ND label near ; A secondary entry point for FILLED_BOX + push SI + mov AX,[BP].arg1 ; Get x upper-left + mov BX,[BP].arg2 ; Get y upper-left +; call Fix_XY ; Force x-ul and y-ul into correct ranges + mov Curr_X,AX + mov Curr_Y,BX + mov AX,[BP].arg3 ; Get x lower-right + mov BX,[BP].arg4 ; Get y lower-right +; call Fix_XY ; Force x-lr and y-lr into correct ranges + cmp AX,Curr_X + jg check_y ; Swap if x-lr < x-ul + xchg AX,Curr_X +check_y: cmp BX,Curr_Y + jg goodargs ; Swap if y-lr < y-ul (origin at top-left) + xchg BX,Curr_Y +; +goodargs: mov Stop_X,AX ; (var. Stop used during clipping only) + mov Stop_Y,BX + overlap box_1,box_done_1 ; if box totally inside CR, no need to clip + ; if box totally outside, skip it + call Clip_box ; else clip box to the clipping rectangle +box_1: mov AX,Stop_X + mov BX,Stop_Y + sub BX,Curr_Y + inc BX ; BX = the height of the box (min=1 pixel) + mov Box_Hite,BX + mov BX,[BP].arg6 ; get function code + mov f_code,BL + mov BX,[BP].arg5 ; get the color + mov pix_c,BX +; All the "common" material taken care of + IFDEF HER + cmp byte ptr VID_MODE+1,1 ;Hercules mono graphics active? + je box_j1 + ENDIF ;HER + IFDEF COMBINED + cmp PC_MAKE,TIPC + je BOX_TI + ENDIF ;COMBINED + IFDEF IBM + jmp BOX_IBM + ENDIF ;IBM + IFDEF HER +box_j1: jmp BOX_HER + ENDIF ;HER + IFDEF TI + jmp BOX_TI + ENDIF ;TI +; +box_done_1: jmp Box_done ; rel. branch not long enough +; + + IFDEF TI +BOX_TI label near + mov AX,Curr_X + mov BX,Curr_Y + call GM_Offset ;get byte address top L corner in DI + mov Left_Offset,DI ;starting address in graphics memory + ;** this address is byte-swapped ** + mov CX,DI + xor CX,1 ;flip addr; TI gfx mem is byte-swapped + mov Left_Side,AX ;get left side of box + mov AL,Start_Line[BX] ;get left corners of box + mov AH,AL + not AL + mov Left_End,AX + mov AX,Stop_X + mov BX,Curr_Y + call GM_Offset ;get byte address top R corner in DI + mov Right_Side,AX ;get right side of box + mov AL,End_Line[BX] ;get right corners of box + mov AH,AL + not AL + mov Right_End,AX + mov Interior,0FF00h ;get interior of box + xor DI,1 ;flip addr; TI gfx mem is byte-swapped + sub DI,CX + inc DI + mov Box_Width,DI ;box occupies this number of bytes + dec DI + jnz tbox_wide +; box fits in 1 byte + mov AX,Right_End ;top/bottom edge + and AX,Left_End + mov AL,AH + not AL + mov Left_End,AX ;left/right sides + mov AX,Right_Side + or AX,Left_Side + mov AL,AH + not AL + mov Left_Side,AX + cmp Fill_Fig,TRUE + jne tinit + mov AX,Left_End + mov Left_Side,AX ;if filled, left/right same as top/bottom + jmp short tinit +; box fits in >1 byte +tbox_wide: cmp Fill_Fig,TRUE + jne tinit + mov AX,Left_End ;if filled ... + mov Left_Side,AX ; left edge same as left top + mov AX,Right_End + mov Right_Side,AX ; right edge same as right top +; initialize +tinit label near + mov DH,byte ptr pix_c ;get color + mov DL,byte ptr Box_Width ;and width + mov DI,Left_Offset + call TI_Solid ;draw top line of box +; take care of vertical dimension +tvloop: dec Box_Hite ;dec height remaining + jz Box_Done ;Box_Hite = 0, done with box + inc Curr_Y ;move to next scan line + mov AX,Curr_X + mov BX,Curr_Y +; this operation is expensive +; instead, calculate the next line's starting address directly +; call GM_Offset ;get offset into graphics page in DI + ;note this address is byte-swapped + add Left_Offset,Bytes_Per_Line ;get offset into graphics page + mov DI,Left_Offset + cmp Box_Hite,1 ;Box_Hite = 1, on bottom line + je tvend + cmp Fill_Fig,TRUE ;filled box? + jne TI_Hollow +tvend: call TI_Solid + jmp tvloop + ENDIF ;TI + +Box_Done: xor AX,AX ; Return a value of zero + pop SI + ret + + IFDEF TI +; the next 2 LABEL's take care of the horizontal dimension +TI_Hollow label near + mov AX,Left_Side ;get left side + mov CL,DH ;get color + call set_byte ;and draw it + cmp DL,1 ;does the box fit in 1 byte? + je tvloop ;yes, jump + xor DI,1 ;remove byte-swap for ADD + add DI,Box_Width ;skip over interior of box + dec DI + xor DI,1 ;put byte-swap back in + mov AX,Right_Side ;get right side + mov CL,DH ;get color + call set_byte ;and draw it + jmp tvloop + +TI_Solid label near ;this is a sbr + mov AX,Left_End ;get left side + mov DL,byte ptr Box_Width ;init width remaining +thloop: mov CL,DH ;get color + call set_byte ;draw it + xor DI,1 ;remove byte-swap for INC + inc DI ;advance to next screen byte + xor DI,1 ;put byte-swap back in + dec DL ;dec width remaining + jz tsexit ;DL = 0, done with horiz scan + cmp DL,1 ;DL = 1, do right edge + je ts_10 + mov AX,Interior + jmp thloop +ts_10: mov AX,Right_End ;get right side + jmp thloop +tsexit: ret + ENDIF ;TI + + IFDEF IBM +; +; +; IBM (ugh!) version of draw box (sorry, but to maintain compatability +; among all the IBM video modes I've used the write-dot function (slow). +; +; modified - 10/10/86 for EGA +; modified - 10/30/87 for faster EGA +; +BOX_IBM label near + cmp vid_mode,14 ; is it EGA? + jl IBM_10 ; no, skip + jmp Box_EGA ; yes + +; CGA boxes +IBM_10: sub AX,Curr_X + inc AX ; Box_Width (number of pixels to draw line) + mov Box_Width,AX + call IBM_Solid ; Draw the top line of box + inc Curr_Y + dec Box_Hite + jz Box_Done +IBM_while: cmp Box_Hite,1 + je IBM_botm ; Go draw bottom line + cmp Fill_Fig,TRUE ; Is box to be filled or not? + jne IBM_nofill + call IBM_Solid + jmp short IBM_fi +; +IBM_nofill: call IBM_epts ; Draw the side points for current scan line +IBM_fi: inc Curr_Y ; end of "if" + dec Box_Hite + jmp IBM_while + +IBM_botm: call IBM_Solid ; Draw bottom line (needs to be solid) + jmp Box_Done +; +IBM_Solid label near ; Draw a solid horizontal line + + mov DI,Box_Width ; sounds more like a room freshener :-) + mov DX,Curr_Y + mov CX,Curr_X + +; cmp vid_mode,14 ;commented out 10/30/87 - rb +; jge ega_box + + mov BL,byte ptr [BP].arg5 ; Get the color + cmp f_code,1 ; is xor flag set? + jne I_Sloop ; no + or BL,080h ; set xor flag on +I_Sloop: mov AH,0Ch ; write-dot function + mov AL,BL ; copy the color + int IBM_CRT ; WRITE-DOT(x,y,color) + inc CX + dec DI + jnz I_Sloop + ret +; +IBM_epts label near ; Draw the end points of a horizontal line + mov DX,Curr_Y + mov CX,Curr_X + mov BL,byte ptr [BP].arg5 ; Get the color + call epts + cmp Box_Width,1 ; Do we need to do the other end? + je I_eend + add CX,Box_Width + dec CX ; We added 1 too many + call epts +I_eend: ret + +epts proc near + mov AH,0Ch ; write-dot function + mov AL,BL + cmp f_code,1 + jne epts_01 + or AL,080h ; set xor bit +epts_01: int IBM_CRT ; Write Left dot + ret +epts endp + + comment ~ ; commented out 10/30/87 - rb +;******************************************************************** +;* * +;* EGA_BOX will draw a solid line on the EGA screen. This method * +;* is used in preference to write dot since write dot is so slow.* +;* * +;* DX = start row * +;* CX = start col * +;* DI = length * +;* * +;******************************************************************** + +ega_box: mov AX,CX ; put start col into AX + add AX,DI ; AX is not the ending column + dec AX ; added one too many + call xxset + ret + ~ ;end commented-out code + +BOX_EGA label near + mov AX,Curr_X + mov BX,Curr_Y + call EGA_GM_Offset ;get byte address top L corner in DI + mov Left_Offset,DI ;starting address in graphics memory + mov Left_Side,AX ;get left side of box + mov AL,Start_Line[BX] ;get left corners of box + mov AH,AL + not AL + mov Left_End,AX + mov AX,Stop_X + mov BX,Curr_Y + call EGA_GM_Offset ;get byte address top R corner in DI + mov Right_Side,AX ;get right side of box + mov AL,End_Line[BX] ;get right corners of box + mov AH,AL + not AL + mov Right_End,AX + mov Interior,0FF00h ;get interior of box + sub DI,Left_Offset + inc DI + mov Box_Width,DI ;box occupies this number of bytes + dec DI + jnz ebox_wide +; box fits in 1 byte + mov AX,Right_End ;top/bottom edge + and AX,Left_End + mov AL,AH + not AL + mov Left_End,AX ;left/right sides + mov AX,Right_Side + or AX,Left_Side + mov AL,AH + not AL + mov Left_Side,AX + cmp Fill_Fig,TRUE + jne einit + mov AX,Left_End + mov Left_Side,AX ;if filled, left/right same as top/bottom + jmp short einit +; box fits in >1 byte +ebox_wide: cmp Fill_Fig,TRUE + jne einit + mov AX,Left_End ;if filled ... + mov Left_Side,AX ; left edge same as left top + mov AX,Right_End + mov Right_Side,AX ; right edge same as right top +; initialize EGA registers +einit: seqout 2,0Fh ;enable sequencer Map Mask register + mov CH,f_code + or CH,CH + jz no_xor + mov CH,18h +no_xor: grafout 3,CH ;xor state + grafout 0, ;color + grafout 1,0Fh ;enable all color planes +; other initialization + mov AX,0A000h ;EGA screen memory starts at A000:0 + mov ES,AX + mov DI,Left_Offset + call EGA_Solid ;draw top line of box +; take care of vertical dimension +evloop: dec Box_Hite ;dec height remaining + jz evexit ;Box_Hite = 0, done with box + inc Curr_Y ;move to next scan line + mov AX,Curr_X + mov BX,Curr_Y + mov CX,pix_c + call EGA_GM_Offset ;get offset into graphics page in DI + cmp Box_Hite,1 ;Box_Hite = 1, on bottom line + je evend + cmp Fill_Fig,TRUE ;filled box? + jne EGA_Hollow ;no, jump +evend: call EGA_Solid ;yes + jmp evloop +; reset EGA registers +evexit: grafout 0,0 + grafout 1,0 + grafout 3,0 + grafout 8,0FFh + jmp Box_Done + +; the next 2 LABEL's take care of the horizontal dimension +EGA_Hollow label near + mov BX,Left_Side ;get left side + call set_pixel3 ;and draw it + cmp Box_Width,1 ;does the box fit in 1 byte? + je evloop ;yes, jump + add DI,Box_Width ;skip over interior of box + dec DI + mov BX,Right_Side ;get right side + call set_pixel3 ;and draw it + jmp evloop + +EGA_Solid label near ;; ** this is a sbr ** + mov BX,Left_End ;get left side + mov CX,Box_Width ;init width remaining +ehloop: +; push CX ;tempsave it +; mov CX,pix_c + call set_pixel3 ;draw it + inc DI ;advance to next screen byte +; pop CX ;restore width remaining + dec CX ;dec width remaining + jcxz esexit ;CX = 0, done with horiz scan + cmp CX,1 ;CX = 1, do right edge + je es_10 + mov BX,Interior + jmp ehloop +es_10: mov BX,Right_End ;get right side + jmp ehloop +esexit: ret + ENDIF ;IBM + + IFDEF HER +BOX_HER label near + mov AX,Curr_X + mov BX,Curr_Y + call Her_GM_Offset ;get byte address top L corner in DI + mov Left_Offset,DI ;starting address in graphics memory + mov Left_Side,AX ;get left side of box + mov AL,Start_Line[BX] ;get left corners of box + mov AH,AL + not AL + mov Left_End,AX + mov AX,Stop_X + mov BX,Curr_Y + call Her_GM_Offset ;get byte address top R corner in DI + mov Right_Side,AX ;get right side of box + mov AL,End_Line[BX] ;get right corners of box + mov AH,AL + not AL + mov Right_End,AX + mov Interior,0FF00h ;get interior of box + sub DI,Left_Offset + inc DI + mov Box_Width,DI ;box occupies this number of bytes + dec DI + jnz hbox_wide +; box fits in 1 byte + mov AX,Right_End ;top/bottom edge + and AX,Left_End + mov AL,AH + not AL + mov Left_End,AX ;left/right sides + mov AX,Right_Side + or AX,Left_Side + mov AL,AH + not AL + mov Left_Side,AX + cmp Fill_Fig,TRUE + jne hinit + mov AX,Left_End + mov Left_Side,AX ;if filled, left/right same as top/bottom + jmp short hinit +; box fits in >1 byte +hbox_wide: cmp Fill_Fig,TRUE + jne hinit + mov AX,Left_End ;if filled ... + mov Left_Side,AX ; left edge same as left top + mov AX,Right_End + mov Right_Side,AX ; right edge same as right top +; initialize +hinit: mov ES,her_page ;seg addr of active graphics page + mov DI,Left_Offset + call Her_Solid ;draw top line of box +; take care of vertical dimension +vloop: dec Box_Hite ;dec height remaining + jz vexit ;Box_Hite = 0, done with box + inc Curr_Y ;move to next scan line + mov AX,Curr_X + mov BX,Curr_Y + mov CX,pix_c + call Her_GM_Offset ;get offset into graphics page in DI + cmp Box_Hite,1 ;Box_Hite = 1, on bottom line + je vend + cmp Fill_Fig,TRUE ;filled box? + jne Her_Hollow ;no, jump +vend: call Her_Solid ;yes + jmp vloop +vexit: jmp Box_Done + +; the next 2 LABEL's take care of the horizontal dimension +Her_Hollow label near + mov AX,Left_Side ;get left side + call set_pixel2 ;and draw it + cmp Box_Width,1 ;does the box fit in 1 byte? + je vloop ;yes, jump + add DI,Box_Width ;skip over interior of box + dec DI + mov AX,Right_Side ;get right side + call set_pixel2 ;and draw it + jmp vloop + +Her_Solid label near ;; ** this is a sbr ** + mov AX,Left_End ;get left side + mov CX,Box_Width ;init width remaining +hloop: push CX ;tempsave it + mov CX,pix_c + call set_pixel2 ;draw it + inc DI ;advance to next screen byte + pop CX ;restore width remaining + dec CX ;dec width remaining + jcxz hsexit ;CX = 0, done with horiz scan + cmp CX,1 ;CX = 1, do right edge + je hs_10 + mov AX,Interior + jmp hloop +hs_10: mov AX,Right_End ;get right side + jmp hloop +hsexit: ret + ENDIF ;HER + +BOX endp + +set_pixel2 proc near + +; on entry: +; AH = byte to be written to screen memory +; AL = NOT AH +; CL = color +; ES:DI = address in screen memory +; on exit: +; the same registers are unchanged + + cmp f_code,0 ;xor? + jnz zero_xor ;yes, jump +; overwrite + test CL,PIXEL_ON ;turn on pixel? + jz zero_over ;no, jump +; overwrite with 1 + or ES:[DI],AH + ret +; overwrite with 0 +zero_over: and ES:[DI],AL + ret +; xor +zero_xor: test CL,PIXEL_ON ;turn on pixel? +; xor with 0 + jz zexit ;no; 0 xor any = any, so nothing changes +; xor with 1 + xor ES:[DI],AH +zexit: ret +set_pixel2 endp + + IFDEF IBM +set_pixel3 proc near + +; on entry: +; BH = byte to be written to screen memory +; BL = NOT AH +; ES:DI = address in screen memory +; It's assumed that other EGA Graphics registers have been set up already +; and that only the Graphics Bit Mask register needs to be changed. +; on exit: +; the same registers are unchanged +; destroyed: +; AX,DX (by "grafout" macro) + + grafout 8,BH + mov AH,ES:[DI] ;set EGA latches + mov ES:[DI],AH ;then write EGA registers out + ret +set_pixel3 endp + ENDIF ;IBM + + comment ~ ;commented out 10/30/87 - rb + IFDEF IBM + public xxset +XXSET PROC NEAR + + PUSH ES + PUSH DX + PUSH DX + PUSH AX + + MOV FUNC,0 ; DEFAULT TO DATA UNMODIFIED + CMP F_CODE,0 ; IS THIS An xor'ed box? + JE AND_TYPE + MOV FUNC,18H ; SET TO XOR +AND_TYPE: + MOV AX,CX ; PUT THE START COLUMN IN + MOV BX,DX ; PUT THE ROW IN + CALL GET_OFFSET ; CALCULATE START ADDR, OFFSET + CMP BX,8 ; ON A WORD BOUNDARY? + JL BYTE_01 ; YES, THEN CONTINBUE + INC AX ; BUMP THE WORD OFFSET + SUB BX,8 ; ADJUST FOR NEW BYTE ADDRESS +BYTE_01: + MOV ST_WORD,AX ; SAVE START ADDRESS AND + MOV ST_BIT,BX ; BIT OFFSET + + POP AX ; RESET THE END COLUMN + POP BX ; POP DX INTO BX - ROW + CALL GET_OFFSET ; CALCULATE END ADDR, OFFSET + CMP BX,8 ; ON A WORD BOUNDARY? + JL BYTE_02 ; YES, THEN CONTINBUE + INC AX ; BUMP THE WORD OFFSET + SUB BX,8 ; ADJUST FOR NEW BYTE ADDRESS +BYTE_02: + MOV ED_WORD,AX ; SAVE START ADDRESS AND + MOV ED_BIT,BX ; BIT OFFSET + +; Now to set up the addresses and masks and write to the planes + MOV DI,ST_WORD ; SET THE STARTING OFFSET + +XOR_LOOP: + MOV AL,-1 + CMP DI,ST_WORD ; STARTING OFFSET? + JNE END_OFF ; IF NOT, THEN CHECK FOR ENDING OFFSET + MOV CX,ST_BIT ; SUBTRACT THE STARTING BIT OFFSET + SHR AL,CL ; SET UP THE CORRECT MASK FOR START +END_OFF: ; End of offset processing + CMP DI,ED_WORD ; IS THIS THE LAST BYTE TO PROCESS? + JNE DO_XOR ; NO, THEN XOR THE DATA AND UPDATE + MOV AH,-1 ; INITIALIZE THE MASK + MOV CX,7 + SUB CX,ED_BIT ; SUBTRACT THE # OF ENDING OFFSET + SHL AH,CL ; WANT TO SAVE ALL BUT BITS PAST END + AND AL,AH ; AND OFF ALL USELESS BITS +DO_XOR: + + ; Latch up the current mask + PUSH AX + MOV DX,3CEH ; LATCH PORT + MOV AL,8 ; BIT MASK = on + OUT DX,AL + INC DX + POP AX ; RESTORE THE CURRENT MASK + OUT DX,AL + + CMP FUNC,18H + JNE WRT_ZEROS ; IF XOR, THE ONLY DO 1'S + +; Set to XOR function + DEC DX + MOV AL,3 ; DATA ROTATE REGISTER + OUT DX,AL ; WRITE IT + MOV AL,FUNC ; SET THE XOR OPERATOR + INC DX ; to or everything on to the planes + OUT DX,AL + JMP WRT_ONES + +WRT_ZEROS: +; Write the one to the planes that are set + + MOV DX,3C4H ; SEQUENCER ADDRESS + MOV AL,2 ; + OUT DX,AL + + MOV AX,PIX_C ; SET THE COLOR INTO THE AL + XOR AL,0FH ; SET THE ZERO PLANES TO ON + INC DX + OUT DX,AL ; ENABLE THIS PLANE + MOV ES,gra_ram ; GRAPHICS RAM ADDRESS + + MOV AL,ES:[DI] ; LATCH UP THE EXISTING DATA + XOR AL,AL ; WRITE ZEROES + MOV ES:[DI],AL ; OR WORD IN GRAPHICS PLANE. + +; Now write to the planes that are ONESes + +WRT_ONES: + MOV DX,3C4H ; SEQUENCER ADDRESS + MOV AL,2 ; + OUT DX,AL + + MOV AX,PIX_C ; SET THE COLOR INTO THE AL + INC DX + OUT DX,AL ; ENABLE THIS PLANE + MOV ES,GRA_RAM ; GRAPHICS RAM ADDRESS + + MOV AL,ES:[DI] ; LATCH UP THE EXISTING DATA + MOV AL,0FFH ; WRITE ONES + MOV ES:[DI],AL ; OR WORD IN GRAPHICS PLANE. + +; Now ready to update the pointers and continue + +NEXT_BYTE: + + CMP DI,ED_WORD ; PROCESSED LAST ONE? + JE XOR_EXIT + INC DI ; NEXT WORD IN THE GRAPHICS PLANES + JMP XOR_LOOP ; DO NEXT BYTE + +XOR_EXIT: + + MOV DX,3C4H ; SEQUENCER ADDRESS + MOV AL,2 ; + OUT DX,AL + + MOV AL,0FFH ; ENABLE ALL BAMNK + INC DX + OUT DX,AL ; ENABLE THIS PLANE + + MOV DX,3CEH ; SEQUENCER ADDRESS + MOV AL,3 ; + OUT DX,AL + + MOV AL,0 ; NORMAL WRITES + INC DX + OUT DX,AL ; ENABLE THIS PLANE + + DEC DX + MOV AL,8 ; + OUT DX,AL + + MOV AL,0FFH ; ALL BITS + INC DX + OUT DX,AL ; ENABLE THIS PLANE + + POP DX + POP ES + RET +; +XXSET ENDP + +get_offset proc near + +; AX has the pixel column number +; BX has the pixel row number + + div b_p_wrds ; divide by bits per word + push AX ; save the bit offset + mov AX,BX ; get the pixel row + mul w_p_row ; row * 46 words per row + pop BX ; get words and bit within row + push BX ; save it again + xor BH,BH ; get rid of bit + add AX,BX ; bump to absolute offset + mul two ; byte offset! + pop BX + mov BL,BH ; shift bit count to bl + xor BH,BH + ret + ; return - ax=word offset ; bx=bit offset + +get_offset endp + ENDIF ;IBM + ~ ;end commented-out code + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page + + comment ~ ;this code commented out 9/8/87 - rb + +;*************************************************************************** +; XXSET - PUT A LINE ON THE SCREEN AT THE START, END LOC AND OF LENGTH L +; AX=START COL, BX=START ROW , CX=END COL +; COLOR = COLOR +;*************************************************************************** + public ti_xxset +ti_xxset proc near + push ES +; + mov AX,curr_x + mov BX,y_val + mov CX,stop_x +; + push BX ; save the start row + call get_offset ; convert row/col to word/bit offset + + mov st_word,AX ; save the start row offset + mov st_bit,BX ; save the start bit offset + pop BX ; restore the start row + mov AX,CX ; get the ending col + call get_offset ; convert to word/bit offset + + mov ed_word,AX ; save the ending word offset + mov ed_bit,BX ; save the ending bit offset +; Determine the starting word mask + mov BX,st_word ; get the starting word offset +ti_xloop: + mov DX,-1 + cmp BX,st_word + jne ti_endoff + mov CX,st_bit ; starting bit offset + shr DX,CL ; shift off one bits until mask gotten +ti_endoff: + cmp BX,ed_word ; last byte to process? + jne ti_xor ; no. then xor and update + push DX ; save mask + mov DX,-1 ; initialize mask + mov CX,0fh + sub CX,ed_bit ;subtract the # of ending offset + shl DX,CL ; want to save allbut bits past end + pop AX ; and off all useless bits + and DX,AX + +ti_xor: mov CX,pix_c ; get the color + call ti_xor_word + cmp BX,ed_word + je ti_exit + + add BX,2 ; bump the offset to next word + jmp ti_xloop ; do next word +ti_exit: + pop ES + inc y_val + ret +; +ti_xxset endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page + +;***************************************************************************** +; XOR_WORD - XOR THE MASK IN THE DX INTO THE 3 GRAPHICS PLANES AT OFFSET +; XOR THE DATA INTO THE THREE GRAPHICS PLANES +; BX = WORD OFFSET , DX=MASK , CX=COLOR +;**************************************************************************** + +ti_xor_word proc near + + test CX,01h ; xor this plane only if bit set + jz xor_b ; no, then go to b plane + mov ES,bank_a ; get the seg addr of the a plane + call doit +; +xor_b: + test CX,02h ; xor this plane only if bit set + jz xor_c ; no, then go to c plane + mov ES,bank_b ; get the seg addr of the b plane + call doit + +xor_c: + test CX,04h ; xor this plane only if bit set + jz xor_end ; no, then go bump the offset + mov ES,bank_c ; get the seg addr of the c plane + call doit + +xor_end: + ret +ti_xor_word endp + +doit proc near + mov AX,ES:[BX] ; get the word from a plane + xor AX,DX ; xor the word + mov ES:[BX],AX ; put it back + ret +doit endp + +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + ~ ;end commented-out code + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name FILLED_BX -- Draw a solid box in the graphics plane with the +; specified color. +; +; synopsis (filled_box x-ul y-ul x-lr y-lr color) +; +; description Draw a filled box with graphics (not text characters). +; The upper left-hand corner is specified by (x-ul,y-ul) +; and the lower right-hand is specified by (x-lr,y-lr). +; Color indicates the pixel values that will make up the +; box. The interior will be filled with the same color +; as the box. The box is clipped. +; +; returns nothing +; +FILLD_BX proc near + mov Fill_Fig,TRUE + call BOX_2ND ; Call BOX at a second entry point + ret +FILLD_BX endp +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- + page +;----------------------------------------------------------------------------- +; name SET_CLIP_RECT - Set the clipping rectangle. +; +; synopsis (set-clipping-rectangle! left top right bottom) +; +; description This routine sets the clipping rectangle for the screen. +; The coordinate values can be any signed integer. The +; intersection of the clipping rectangle and the screen is +; used as the final clipping rectangle. If this would be nil, +; the clipping rectangle is set to the full screen; we never +; let it become invisible. +; +; returns nothing +; +; in: no registers +; out: no registers +; destroyed: AX,BX,CX,DX +;----------------------------------------------------------------------------- +SET_CLIP_RECT proc near + IFDEF HER + cmp byte ptr VID_MODE+1,1 + je SCR_Her + ENDIF ;HER + IFDEF COMBINED + cmp PC_MAKE,TIPC + je SCR_TI + ENDIF ;COMBINED + IFDEF IBM + call Reset_CR_IBM ; set CR to screen's full size + jmp short SCR_join + ENDIF ;IBM + IFDEF HER +SCR_Her: call Reset_CR_Her ; set CR to screen's full size + jmp short SCR_join + ENDIF ;HER + IFDEF TI +SCR_TI: call Reset_CR_TI ; set CR to screen's full size + ENDIF ;TI +SCR_join: mov AX,[BP].arg1 + mov BX,[BP].arg2 + mov CX,[BP].arg3 + mov DX,[BP].arg4 + ; rearrange coordinates so first point is upper left hand corner + cmp CX,AX ; swap if x-lr < x-ul + jg SCR_1 + xchg CX,AX +SCR_1: cmp DX,BX ; swap if y-lr < y-ul (origin at top left) + jg SCR_2 + xchg DX,BX + ; now we can continue +SCR_2: mov Curr_X,AX ; store for the overlap check + mov Curr_Y,BX + mov Stop_X,CX + mov Stop_Y,DX + overlap SCR_3,SCR_4 ; check how screen and CR overlap + call Clip_box ; they overlap, clip +SCR_3: mov AX,Curr_X ; move new coords to be final CR + mov clip_left,AX + mov BX,Curr_Y + mov clip_top,BX + mov AX,Stop_X + mov clip_right,AX + mov BX,Stop_Y + mov clip_bottom,BX +SCR_4: ret +SET_CLIP_RECT endp + + page + IFDEF IBM +;----------------------------------------------------------------------------- +; Reset the clipping rectangle to the full size of the screen for IBM modes. +; Destroys AX and BX. +;----------------------------------------------------------------------------- +Reset_CR_IBM proc near + mov AH,15 ; get the current video mode + int IBM_CRT + cmp al,Res_Table_IBM_Length-1 ; cmp with max video mode + jb RCI_1 + mov al,Res_Table_IBM_Length-1 ; map out-of-range values to + ; last entry in table +RCI_1: cbw + shl AX,1 ; multiply by 4 + shl AX,1 + mov BX,AX + mov clip_left,0 ; set the clipping rectangle accordingly + mov clip_top,0 + mov AX,Res_Table_IBM[BX] + mov clip_right,AX + mov AX,Res_Table_IBM+2[BX] + mov clip_bottom,AX + ret +Reset_CR_IBM endp + ENDIF ;IBM + + IFDEF TI +;----------------------------------------------------------------------------- +; Reset the clipping rectangle to the full size of the screen for TIPC. +; No registers are affected. +;----------------------------------------------------------------------------- +Reset_CR_TI proc near + mov clip_left,0 + mov clip_top,0 + mov clip_right,X_max-1 + mov clip_bottom,Y_max-1 + ret +Reset_CR_TI endp + ENDIF ;TI + + IFDEF HER +;----------------------------------------------------------------------------- +; Reset the clipping rectangle to the full size of the screen for Hercules. +; No registers are affected. +;----------------------------------------------------------------------------- +Reset_CR_Her proc near + mov clip_left,0 + mov clip_top,0 + mov clip_right,her_xmax-1 + mov clip_bottom,her_ymax-1 + ret +Reset_CR_Her endp + ENDIF ;HER + ENDIF ;VMXLI (matches IFNDEF at beginning of PROGX segment) + + + page +;----------------------------------------------------------------------------- +;----------------------------------------------------------------------------- +; +; name XPCINIT - Any special initialization required for a +; particular type PC (e.g. IBM) +; +; synopsis call far xpcinit (from PGROUP) +; +; description A C callable routine (well, almost) that should be used +; internally to PCS for any special initialization that may +; be needed for a particular PC. +; +; returns nothing ('cept personal satisfaction) +; + public XPCINIT + +; For TIPC's we actively set "mode 3". +; For IBM's we just note whatever mode is currently in effect. + +XPCINIT proc far + + IFDEF COMBINED + cmp PC_MAKE,TIPC + jne not_ti + mov w_p_row,46 + mov AX,offset XGROUP:endinit ; THIS IS REALLY UGLY!!! + push AX ; push return address (return from all_on) + push BP + push ES + push VID_MODE + jmp all_on ; Turn on TEXT, init & clear graphics +; +not_ti: cmp PC_MAKE,0FCh + jl not_ibm + mov AX,0500h ; Set active display page (for alpha modes) + int IBM_CRT ; should I check for graphics mode??? Nah! + + mov AH,15 ; get current video mode + int IBM_CRT + xor AH,AH ; clear AH + mov VID_MODE,AX ; save video mode + mov w_p_row,40 + cmp AX,16 + jne short endinit + mov char_hgt,14 + + jmp short endinit +; +not_ibm label near ; Could there be a Zenith Z-100 out there? + ; Not for now. +endinit: ret + ENDIF ;COMBINED + + IFDEF VMXLI + cmp PC_MAKE,TIPC + jne not_ti + + comment ~ + mov w_p_row,46 + mov AX,offset XGROUP:endinit ; THIS IS REALLY UGLY!!! + push AX ; push return address (return from all_on) + push BP + push ES + push VID_MODE + jmp all_on ; Turn on TEXT, init & clear graphics + ~ ;end comment + +; Do equivalent of (%graphics 0 3 ...) for TI mode. +; This is inline because "xpcinit" executes before XLI does. +; Therefore no XLI graphics drivers are present yet. +; mov AL,DEF_RED +; mov BL,DEF_GRN +; mov CL,DEF_BLU +; mov DL,YES_GRPH +; call pal_set ; Set the graphics palettes on +; mov ES,RED_Palette + push ES ; tempsave ES + mov DI,RED_Pal + mov ES,DI + xor DI,DI ; Zero offset from palette segments + mov byte ptr ES:[DI],DEF_RED ; Set red palette + mov byte ptr ES:[DI]+16,DEF_GRN ; Set green palette + mov byte ptr ES:[DI]+32,DEF_BLU ; Set blue palette +; mov byte ptr GRAFIX_ON,DL ; if graphics are on or not +; mov AL,TEXT_ON +; call txt_set ; Turn text on +; mov ES,Misc_Latch + mov DI,Misc_Lat + mov ES,DI + xor DI,DI + mov byte ptr ES:[DI],TEXT_ON + pop ES ; restore ES + jmp short endinit +; +not_ti: cmp PC_MAKE,0F8h + jl not_ibm + mov AX,0500h ; Set active display page (for alpha modes) + int IBM_CRT ; should I check for graphics mode??? Nah! + + mov AH,15 ; get current video mode + int IBM_CRT + xor AH,AH ; clear AH + mov VID_MODE,AX ; save video mode +; mov w_p_row,40 + cmp AX,16 + jne short endinit + mov char_hgt,14 +; +not_ibm label near ; Could there be a Zenith Z-100 out there? + ; Not for now. +endinit: ret + + ENDIF ;VMXLI + +XPCINIT endp + + + IFDEF XLI + IFDEF XLICOMB +; PCTYPE +; Determine type of PC we are running on and initialize screen. +; +; Returns upon exit: +; Machine Type +; 1 for TIPC or Business Pro in TI mode +; FF for IBM-PC +; FE for IBM-PC/XT +; FD for IBM-PC/jr +; FC for IBM-PC/AT or B-P in IBM mode +; F8 for PS2 Model 80 +; 0 for undeterminable +; Video Mode +; Character Height +; +pctype proc near + push es ; preserve regs for later + push ds + + mov ax,0FC00h ; move paragraph address of copyright +pc_002: mov es,ax ; notice into ES + xor di,di ; Clear DI; 0 is lowest address in ROM @ES: + xor bx,bx ; Flag for "PC_MAKE" + mov cx,40h ; This'll be as far as I go... + mov al,'T' ; look for beginning of "Texas Instruments" + cli ; Stop interrupts - bug in old 8088's +again: + repne scas byte ptr es:[di] ; SEARCH + or cx,cx ; Reach my limit? + jz short pc_005 ; quit if we've exhausted search + cmp byte ptr es:[di],'e' ; make sure this is it + jne again ; use defaults if not found + cmp byte ptr es:[di]+1,'x' ; really make sure this is it + jne again + + push ds + mov ds,bx ; 0->DS for addressing low mem. + + inc bx ; BX==1 => TIPC + mov ax,ds:word ptr [01A2h] ; If TIPC then what kind? + pop ds ; get DS back + + add al,ah ; checkout vector 68 bytes 2 & 3 + cmp al,0F0h ; if AL==F0 then TIPC=Business Pro + jne pc_010 ; jump if not a B-P + + in al,068h ; Read from port + push ax ; Save for later + and al,0FBh ; Enable CMOS + out 068h,al ; Write back out + mov dx,8296h ; I/O address for B-P's mode byte + in al,dx ; TI or IBM Mode on the B-P? + cmp al,0 ; if not zero then B-P emulates a TIPC + pop ax ; Restore original port value + out 068h,al ; and write back out + jne pc_010 ; jump if TIPC else IBM machine code is + ; where it should be. + jmp short pc_007 +pc_005: mov ax,es + cmp ah,0FEh ; test for segment offset FE00 + jae pc_007 ; two checks made? if so, jump + add ah,2 ; go back and check segment offset + jmp pc_002 ; FE00 +pc_007: mov ax,0F000h + + mov es,ax + mov al,byte ptr es:0FFFEh ; IBM's machine code is @F000:FFFE + cmp al,0f0h ; Is this suckah an IBM? + jb pc_010 ; Jump if AL is below F0 (BX will be 0) + mov bl,al +pc_010: + sti ; Turn interrups back on + cmp bx,1 ; TIPC? + jne pc_015 ; no, jump +; tipc, initialize graphics + mov di,0DF01h + mov es,di ; clear graphics planes + xor di,di + mov byte ptr es:[di],0AAh ; set red palette + mov byte ptr es:[di]+16,0CCh ; set green palette + mov byte ptr es:[di]+32,0F0h ; set blue palette + + mov ax,0DF82h + mov es,ax + mov byte ptr es:[di],040h ; turn text on + + mov ax,3 ; ax = video mode + ; bx = pc type code + mov cx,8 ; cx = character height + jmp pc_020 +; ibm, (assumed) get current video mode +pc_015: + push bx ; save pc type code around bios calls + mov ax,0500h ; set active display page (for alpha modes) + int 10h ; bios int + mov ah,15 ; get current video mode + int 10h ; bios int + xor ah,ah ; ax = video mode + pop bx ; bx = pc type code + mov cx,8 ; cx = character height + cmp ax,16 ; if video mode = 16 + jle pc_020 ; then + mov cx,14 ; reset character height +pc_020: + pop ds ; restore local data seg + pop es ; es:di addresses transaction buffer + xor di,di + + mov PC_MAKE,bx ; put PC_MAKE in transaction buffer + mov VID_MODE,ax ; ditto video mode + mov CHAR_HGT,cx ; ditto char height + ret +pctype endp + ENDIF ;XLICOMB + +;----------------------------------------------------------------------------- +; The XLI interface. +;----------------------------------------------------------------------------- + +main proc far ;this file's initial entry point + mov AX,data + mov DS,AX +; mov AX,stack ;establish local stack +; mov SS,AX +IFDEF XLICOMB + call pctype ;initialize type/monitor info +ENDIF + mov psp,ES ;save PSP@ + mov word ptr ES:fb_addr,offset file_block ;poke file block@ + mov word ptr ES:fb_addr+2,seg file_block ;into PSP + mov AX,ES:term_addr ;calc ptrs in PCS to jump to + add AX,3 + mov xwait,AX + add AX,3 + mov xbye,AX + mov AX,ES:term_addr+2 + mov xwait+2,AX + mov xbye+2,AX + mov psize,plen ;calc program size + push psp + push psize + call dword ptr [xwait] ;connect with PCS +; Since this is a XLI SYSINT routine, no XCALL's ever cause a return. +; The only time we return is to terminate. + pop AX + pop AX + call dword ptr [xbye] ;disconnect from PCS +main endp + +progsize = $-progstart +plen equ (progsize+datasize+stacksize+100h+10h)/16 + ENDIF ;XLI + +PROGX ends + +; Now get this assembly terminated with no errors. +; The subterfuge is required since the straightforward approach of +; wrapping a conditional around the END statement doesn't work, +; because the END immediately stops further assembly, including +; seeing the end of the conditional that we started, so the assembler +; detects a "severe error" and won't generate any output. + + IFDEF XLI +endit macro + end main + endm + ELSE +endit macro + end + endm + ENDIF + + endit + + \ No newline at end of file diff --git a/intrup.asm b/intrup.asm new file mode 100644 index 0000000..c888cf8 --- /dev/null +++ b/intrup.asm @@ -0,0 +1,233 @@ +; =====> INTRUP.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Special Keyboard Handlers * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: March 1985 * +;* Last Modification: * +;* 16 Mar 87 - tc * +;* Changed int24 fatal error int * +;* handler to pass extended error * +;* code back to originator. * +;*************************************** +; +; A not-so-ingenius patch to keep PC Scheme from prematurely +; exitting to MS-DOS. CTRL-C now just echos ^C trio +; and this should disappear once the READER is re-written. +; + page 66,132 + include dos.mac + include pcmake.equ + +DOS equ 21h +SHIFT equ 04h ; SHIFT in mode keys +META equ 02h ; ALT " " " +CNTRL equ 01h ; CTRL " " " +C_KEY equ 54h ; Scan code for 'C' key (84 decimal) +BROKEY equ 64h ; Scan code for 'PAUS/BRK' key (100 decimal) + +ERR_INT equ 24h ; Fatal error abort address +EXT_ERR equ 59h ; Get Extended Error Code +TI_KMI equ 5Bh ; TIPC Keyboard Mapping Interrupt +IBM_PBI equ 1Bh ; IBM Program Break Interrupt +BIOS_BRK equ 0071h ; If CTRL-BREAK is pressed on IBM then +BRK_BIT equ 80h ; this bit is set at BIOS_BRK in BIOS data + +CARY_FLG equ 01h ; Carry flag + + DSEG + extrn PC_MAKE:word ; =1 for TIPC, > 0F0h for IBM-PC, =0 for ??? +get_vec dw 3500h+TI_KMI +set_vec dw 2500h+TI_KMI + ENDDS + +PGROUP GROUP PROG +PROG SEGMENT BYTE PUBLIC 'PROG' + ASSUME CS:PGROUP + extrn shft%brk:far +PROG ends + +XGROUP GROUP PROGX +PROGX SEGMENT BYTE PUBLIC 'PROGX' + ASSUME CS:XGROUP,DS:DGROUP + + ; Sorry guys, but this has gotta be in CS: +kbmi_off dw ? ; Keyboard Mapping Interrupt (offset) +kbmi_seg dw ? ; Keyboard Mapping Interrupt (segment) +ferr_off dw ? ; Fatal Error Interrupt (offset) +ferr_seg dw ? ; Fatal Error Interrupt (segment) +;****************** +TI_BRK proc far ; BREAK pressed by (ab)user + cmp AL,BROKEY ; PAUS/BRK key pressed? + jne TI_020 + test AH,SHIFT ; SHIFT pressed with PAUS/BRK? + jz TI_020 ; if no then SHIFT-BRK not possible + test AH,META+CNTRL ; CTRL or ALT pressed with PAUS/BRK? + jnz TI_020 ; if yes then ALT or CTRL has priority +; jmp short TI_010 + +IBM_BRK label far ; Entry point for IBM's Keyboard Break Int. +TI_010 label near + push AX ; Save AX across call + call PGROUP:shft%brk ; Flag to force debugger on next VM instruct + pop AX ; Restore AX + mov AL,0FFh ; Ignore this keystroke (IBM'll ignore this) + +TI_020 label near ; Jump here & return like nothing happened + stc ; Tell TI keyboard DSR that no key was pressd + ; again, IBM BIOS won't care about this. + jmp dword ptr CS:kbmi_off ; Go off and perform task that + ; may have had control of Int 5Bh before + ; we did (e.g. RDClock, etc.). +TI_BRK endp + +;****************** +CTLC_INT proc far ; Handle detection of CTRL-C (INT 23H) + iret ; Just return like nothing happened 'cept + ; that a ^C trio is displayed. +CTLC_INT endp + +;******************* + public FAT_ERR +FAT_ERR proc far ; Handle for fatal error interrupt (24H) + + ; remove ip,cs, and flags of system regs from int 24h + pop AX + pop AX + pop AX + + ; get extended error codes + xor BX,BX + mov AH,EXT_ERR + int DOS ; Extended Error Code returned in AX + + ; restore user registers at time of original function request 21h + pop BX ; Ignore old AX + pop BX + pop CX + pop DX + pop SI + pop DI + pop BP + pop DS + pop ES + + ; Set the carry bit in the caller's flags and return + ; The original dos requestor should see that carry is set and + ; that ax contains the error code + + or byte ptr [BP-02], CARY_FLG + iret +FAT_ERR endp +;****************** +fix%intr proc far ; Re-assign Keyboard Mapping Interrupt (5BH) + push ES ; and "fix" DOS's CTRL-C Exit Interrupt (23H) + push DX + push BX + push AX + cmp PC_MAKE,TIPC ; We running on a TIPC or (yuck) IBM? + je short fix_010 ; Jump as already setup for TIPC + mov al,IBM_PBI + mov byte ptr set_vec,al ; LSB of word in first byte + mov byte ptr get_vec,al +fix_010 label near ; NO CHANGES if you jumped to here + mov AX,get_vec ; get the interrupt vector + int DOS +; + mov word ptr CS:kbmi_seg,ES ; save it + mov word ptr CS:kbmi_off,BX +; + mov AX,set_vec ; Load AX with DOS func # and INT # + mov DX,offset TI_BRK ; for replacing vector with my own + cmp PC_MAKE,TIPC + je short fix_020 ; Jump if we're running on a TIPC + mov DX,offset IBM_BRK ; Use different entry point for IBM + +fix_020 label near + push DS + mov CX,CS ; Do this now as I needed the DS + mov DS,CX ; register back at "cmp PC_MAKE,0" + int DOS +; + mov DX,offset CTLC_INT ; CTRL-C Handler Interrupt (23H) + mov AX,2523h ; This one doesn't need to be restored + int DOS ; and is the same for ALL MS-DOS machines +;************************************************** +;* Install the handler for fatal error interrupt +;************************************************** + pop DS + mov al,ERR_INT + mov AH,35H ; get the original entry + int DOS + + mov word ptr CS:ferr_seg,ES ; save it + mov word ptr CS:ferr_off,BX + mov AH,25H ; set the new entry point + mov AL,ERR_INT + mov DX,offset FAT_ERR ; new address of handler + push DS + mov CX,CS + mov DS,CX + int DOS + + pop DS + pop AX + pop BX + pop DX + pop ES +; + ret ; Get the heck outta here +fix%intr endp + +;****************** +unfix% proc far ; Restore Keyboard Mapping Interrupt (5BH) + ; (DOS should take care of 23H) + push DS + push DX +; + mov AX,set_vec + lds DX,dword ptr CS:kbmi_off ; get old interrupt vector + int DOS + ; Restore fatal error interrupt (24H) + mov AH,25H + mov AL,ERR_INT + lds DX,dword ptr CS:ferr_off + int DOS +; + pop DX + pop DS +; + ret ; Get the heck outta here +unfix% endp +PROGX ends + +;********************************************************************** +;* Link routines * +;********************************************************************** +PROG SEGMENT BYTE PUBLIC 'PROG' + ASSUME CS:PGROUP + Public fix_intr, unfixint + +fix_intr proc near + call fix%intr + ret +fix_intr endp + +unfixint proc near + call unfix% + ret +unfixint endp +prog ends + end + +; **NOTE** +; Let it be known to the world that this programmer +; believes that IBM stands for Immense Bowel Movement!!! +; Or possibly a law firm named Idiots, Bumblers, & Morons. + + end + \ No newline at end of file diff --git a/machtype.asm b/machtype.asm new file mode 100644 index 0000000..2cc6a60 --- /dev/null +++ b/machtype.asm @@ -0,0 +1,76 @@ + page 60,132 + title MACHTYPE - MACHINE TYPE CHECKER + .286c ;; Utilize the expanded 80286 instruction set + +; +; This routine determines the type of machine we are running on by using the +; System Services Bios call (INT 15h), Return System Configuration Parms +; function (AH = C0h). A return code which specifies the machine will be +; returned via the DOS Terminate function (INT 21h, Func 4ch) as follows: +; +; return type machine bios Date +; ----------- ------- --------- +; +; -1 Not a 286/386 machine ---- +; 0 Unknown machine ---- +; 1 IBM PC AT 1/10/84 +; 2 IBM PC AT > 6/10/85 +; 3 IBM PS2 ---- +; +; The information is used to determine shutdown parameters when switching +; between protected and real mode by AI Architects OS286 operating environ- +; ment. +; + + +CODE segment byte public + assume CS:CODE + org 100h +begin: + jmp start + + +start: + push CS + pop DS ;; Set up data segment + mov DX,-1 ;; Default to error condition + +;; See if this is a 286 machine + + mov BX,SP ;; Set up BX with current stack pointer + pusha ;; 286 instruction, ignored on 808x + nop ;; Must be after pusha + cmp BX,SP ;; Were regs pushed? + je MEMRET ;; No...return with error + popa ;; Restore regs + +;; Determine machine + + mov dx,0 ;; Default to unknown + + mov ah,0C0h ;; Return system config parameters + int 15h ;; System services call + jnc CHK286 ;; jump if carry not set + mov dx,1 ;; indicate older AT, bios dated 1/10/84 + jmp MEMRET ;; return + +CHK286: + cmp byte ptr ES:[BX+2],0FCh ;; AT or PS2 model 50 or 60? + jne CHK386 ;; no, jump + cmp byte ptr ES:[BX+3],04h ;; Regular AT or PC XT model 286? + jge GOTPS2 ;; no, see if PS2 Model 80 + mov dx,2 ;; Indicate newer AT, bios dated > 6/10/85 + jmp MEMRET ;; and return +GOTPS2: mov dx,3 ;; Indicate PS2 model 50 or 60 + jmp MEMRET ;; and return +CHK386: + cmp byte ptr ES:[BX+2],0F8h ;; PS2 Model 80? + jne MEMRET ;; No, return + mov dx,3 ;; Indicate PS2 model 80 +MEMRET: + mov AX,DX ;; Return return code + mov AH,4ch + int 21h +CODE ENDS + END begin + \ No newline at end of file diff --git a/memtype.asm b/memtype.asm new file mode 100644 index 0000000..f9b7a52 --- /dev/null +++ b/memtype.asm @@ -0,0 +1,52 @@ + page 60,132 + title MEMTYPE - MEMORY TYPE CHECKER + .286c ;; Utilize the expanded 80286 instruction set + +CODE segment byte public + assume CS:CODE + org 100h +begin: + jmp start + +EmmName db "EMMXXXX0" + +start: + push CS + pop DS ;; Set up data segment + mov DX,0 ;; Default to conventional memory + +;; See if this is a 286 machine + + mov BX,SP ;; Set up BX with current stack pointer + pusha ;; 286 instruction, ignored on 808x + nop ;; Must be after pusha + cmp BX,SP ;; Were regs pushed? + je CHECKEXP ;; No...return + popa ;; Restore regs + + mov AH,88h ;; Get number of contiguous 1k + int 15h ;; blocks starting at 1MByte + cmp AX,0 ;; If none available + je CHECKEXP ;; then jump + inc DX ;; else note extended memory available + +;; Check to see if expanded memory available + +CHECKEXP: + mov AH,35H ;; Get Interrupt Vector + mov AL,67H ;; "Vector" + int 21H + mov DI,000AH ;; ES:DI points to device name field + lea SI,EmmName ;; DS:SI points to device name + mov CX,8 + cld + repe CMPSB ;; Compare the two strings + jne MEMRET ;; If not equal jump + or DX,0002h ;; Note EMM Present +MEMRET: + mov AX,DX + mov AH,4ch + int 21h +CODE ENDS + END begin + \ No newline at end of file diff --git a/msdos.asm b/msdos.asm new file mode 100644 index 0000000..abc4f12 --- /dev/null +++ b/msdos.asm @@ -0,0 +1,471 @@ +;*************************************** +;* MS-DOS Utilities * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 21 June 1984 * +;* Last Modification: 9 June 1986 * +;*************************************** + +MSDOS equ 021h ; MS-DOS interrupt number +GETTIME equ 02Ch ; "get_time" function request id +READ equ 0 +WRITE equ 1 +SELDISK equ 0EH ; select disk +CURDISK equ 019H ; get the current disk +SETADDR equ 01AH ; set disk transfer address +CHNGDIR equ 03BH ; change the current directory +CRFILE equ 03CH ; create a file +OPENFILE equ 03DH ; open a file +CLFILE equ 03EH ; close a file +RFILE equ 03FH ; read from a file +WFILE equ 040H ; write to a file +DELFILE equ 041H ; delete a file function request id +MOVPTR equ 042H ; move file pointer +CURRDIR equ 047H ; return text of current directory +FINDFILE equ 04EH ; find match file +FINDNEXT equ 04FH ; step through a directory, matching files +CHGNAME equ 056H ; move a directory entry + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +curdrv db 0 + db 3AH ; ':' + db 5CH ; '\' +curdir db 64 dup (0) +dta db 43 dup (0) +filespec db 13 dup (0) +data ends + +XGROUP group progx +progx segment byte public 'PROGX' + assume CS:XGROUP,DS:DGROUP +;;; +;;; Delete a file +;;; +del_arg struc + dw ? ; caller's BP + dd ? ; return address (long) + dw ? ; original return address (short) +filename dw ? ; file name +del_arg ends + +dos%del proc far + push BP + mov BP,SP + mov DX,[BP].filename ; DX points to ASCIZ pathname + mov AH,DELFILE ; delete a file + int MSDOS + jc del_ret + xor AX,AX ; carry not set, return zero +del_ret: pop BP + ret +dos%del endp +;;; +;;; Copy a file +;;; +copy_arg struc +handle1 dw ? ; source file handle +handle2 dw ? ; destination file handle +copy_buf db 128 dup (0) ; temporary buffer for copy +copy_BP dw ? ; caller's BP + dd ? ; return address + dw ? ; original return address +file1 dw ? ; source file name +file2 dw ? ; destination file name +copy_arg ends + +dos%copy proc far + push BP + sub SP,offset copy_BP ; allocate local storage + mov BP,SP + mov DX,[BP].file1 + mov AH,OPENFILE ; open a file (source) + mov AL,READ ; access mode: read + int MSDOS + jc copy_ret ; carry set, return + mov [BP].handle1,AX + mov DX,[BP].file2 + mov CX,0 ; file attribute + mov AH,CRFILE ; create a file (destination) + int MSDOS + jc copy_ret + mov [BP].handle2,AX +; copy bytes from source file to destination file +copy_01: lea DX,[BP].copy_buf + mov CX,128 + mov BX,[BP].handle1 + mov AH,RFILE ; read from file + int MSDOS + cmp AX,0 ; end of file? + je copy_10 ; yes, jump + mov CX,AX ; number of bytes to move + lea DX,[BP].copy_buf + mov BX,[BP].handle2 + mov AH,WFILE ; write to a file + int MSDOS + jmp copy_01 +; close source file and destination file +copy_10: mov BX,[BP].handle1 + mov AH,CLFILE ; close a file + int MSDOS + mov BX,[BP].handle2 + mov AH,CLFILE ; close a file + int MSDOS + xor AX,AX +copy_ret: add SP,offset copy_BP ; release local storage + pop BP + ret +dos%copy endp +;;; +;;; Rename files under current directory +;;; +ren%mov proc near + cmp byte ptr [DI],2ah ; an '*' + je renmv1 + cmp byte ptr [DI],3fh ; a '?' + je renmv1 + mov AL,byte ptr [DI] ; otherwise move in the new file char +renmv1: mov byte ptr [BX],AL + ret +ren%mov endp + +ren_arg struc +ren_BP dw ? ; caller's BP + dd ? ; return address + dw ? ; original return address +oldfile dw ? ; old file name +newfile dw ? ; new file name +ren_arg ends + +dos%ren proc far + push BP + mov BP,SP + + mov DX,offset DGROUP:dta + mov AH,SETADDR ; set disk transfer address + int MSDOS + + mov DX,[BP].oldfile + mov CX,0 ; search attribute + mov AH,FINDFILE ; find match file + int MSDOS + jc ren_ret + +ren_01: mov SI,offset DGROUP:dta + add SI,29 ; points to filespec + mov DI,[BP].newfile + mov BX,offset DGROUP:filespec + +ren_02: inc SI + cmp byte ptr ES:[SI],00h ; end of the string + je ren_03 + cmp byte ptr ES:[SI],2eh ; an '.'? + je ren_03 + mov AL,byte ptr ES:[SI] + call ren%mov + inc DI + inc BX + cmp byte ptr [DI-1],2ah + jne ren_02 + cmp byte ptr [SI+1],2eh ;next char a '.'? + je ren_02 + dec DI + jmp ren_02 +; +ren_03: + cmp byte ptr [DI],00h ; end of the string + je ren_04 + cmp byte ptr [DI],3fh ; a '?' + je ren_04 + cmp byte ptr [DI],2ah ; an '*' + je ren_04 + cmp byte ptr [DI-1],2eh ; previous character a '.'? + je ren_02 + mov AL,byte ptr ES:[SI-1] + call ren%mov + inc DI + inc BX + jmp ren_03 +; +; rename the file +; +ren_04: mov byte ptr [BX],0 + mov DI,offset DGROUP:filespec + mov DX,offset DGROUP:dta + add DX,30 + mov AH,CHGNAME ; move a directory entry + int MSDOS + + mov AH,FINDNEXT ; find next match file + int MSDOS + jnc ren_01 ; carry not set, do next file +ren_100: xor AX,AX +ren_ret: pop BP + ret +dos%ren endp + +;;; +;;; Get the file size +;;; +size_arg struc + dw ? ; caller's BP + dd ? ; caller's return address + dw ? +file dw ? +size_arg ends + +dos%size proc far + push BP + mov BP,SP + mov DX,offset DGROUP:dta + mov AH,SETADDR ; set disk transfer address + int MSDOS + mov DX,[BP].file + mov CX,0 ; search attribute + mov AH,FINDFILE ; find match file + int MSDOS + jnc size_01 + xor BX,BX ; return 0 for invalid access + xor AX,AX + jmp size_ret +size_01: mov DI,offset DGROUP:dta + mov AX,word ptr [DI+28] ; high word of file size + mov BX,word ptr [DI+26] ; low word of file size +size_ret: pop BP + ret +dos%size endp +;;; +;;; Change the current directory +;;; +cd_arg struc +cd_BP dw ? ; caller's BP + dd ? ; caller's return address + dw ? +dir dw ? +cd_arg ends +dos%cd proc far + push BP + mov BP,SP + mov AH,CURDISK ; current disk + int MSDOS + inc AL + mov DL,AL ; drive number + add AL,40H ; drive character + mov curdrv,AL + mov SI,offset DGROUP:curdir + mov AH,CURRDIR ; return current directory + int MSDOS + mov DX,[BP].dir + mov AH,CHNGDIR ; change the current directory + int MSDOS + mov AX,offset DGROUP:curdrv +cd_ret: pop BP + ret +dos%cd endp +;;; +;;; Change the current drive +;;; +drv_arg struc + dw ? ; caller's BP + dd ? ; caller's return address + dw ? +drive db ? +drv_arg ends +dos%drv proc far + push BP + mov BP,SP + mov DL,[BP].drive + mov AH,CURDISK ; current disk + int MSDOS + mov [BP].drive,AL + sub DL,41H ; get the drive number + cmp DL,0 + jl drv_ret + cmp DL,10 ; maximum nuber of drive? + jg drv_ret + mov AH,SELDISK ; select disk + int MSDOS + cmp DL,AL ; AL = number of drives + jl drv_01 + mov DL,[BP].drive ; get the current disk + mov AH,SELDISK ; select disk + int MSDOS + jmp drv_ret +drv_01: xor AX,AX + jmp drv_ret1 +drv_ret: mov AX,-1 ; error +drv_ret1: pop BP + ret +dos%drv endp +;;; +;;; Move the file pointer right before EOF character and overwrite it +;;; to fix the bug in open-extend-file +;;; +mov_arg struc +m_buffer dw 0 +mov_BP dw ? ; caller's BP + dd ? ; caller's return address + dw ? +fhandle dw ? ; file handle +mov_arg ends + +mov%fptr proc far + push BP + sub SP,offset mov_BP ; allocate for local variable + mov BP,SP + mov AL,2 ; move the pointer to end of file + mov DX,-128 ; and with offset (one record size) + mov CX,-1 + mov AH,MOVPTR + mov BX,[BP].fhandle ; file handle + int MSDOS + jc mov_ret + cmp DX,0 ; small file? + jge mov_001 + mov AL,0 + xor CX,CX + xor DX,DX + mov AH,MOVPTR + int MSDOS + jc mov_ret +mov_001: lea DX,[BP].m_buffer ; address of buffer +mov_01: mov CX,1 ; read one character at a time + mov AH,RFILE ; read it + int MSDOS + jc mov_ret + mov CL,byte ptr [BP].m_buffer + cmp CL,1AH ; reach eof character? + je mov_05 ; yes, go overwrite it + cmp AX,0 ; at eof, but no eof char? + je mov_ret ; Yes, return + jmp short mov_01 ; No, loop +; file pointer right after the EOF character +mov_05: mov AL,1 ; move the pointer to the current + mov DX,-1 ; location plus offset + mov CX,-1 + mov AH,MOVPTR + int MSDOS + jc mov_ret +; file pointer points to EOF character + mov CX,1 ; write one byte + mov BX,[BP].fhandle ; file handle + mov [BP].m_buffer,0 + lea DX,[BP].m_buffer ; address of buffer + mov AH,WFILE ; write it + int MSDOS + jc mov_ret + mov AL,1 ; move the pointer to the current + mov DX,-1 ; location plus offset + mov CX,DX + mov AH,MOVPTR + mov BX,[BP].fhandle ; file handle + int MSDOS + jc mov_ret + xor AX,AX +mov_ret: add SP,offset mov_BP ; release local storage + pop BP + ret +mov%fptr endp +progx ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +get_args struc + dw ? ; caller's BP + dw ? ; return address +get_ary dw ? ; pointer to result array +get_args ends + +time_fmt struc ; format of data returned by get_time() +tim_hour dw ? ; hour +tim_min dw ? ; minute +tim_sec dw ? ; seconds +tim_hnds dw ? ; hundredths +time_fmt ends + + public get_time +get_time proc near + push BP ; save caller's BP + mov BP,SP ; establish operand addressability + + mov AH,GETTIME ; load "get_time" service call id + int MSDOS ; request service from MS-DOS + mov BX,[BP].get_ary ; load pointer to result array + xor AX,AX ; clear AX + mov AL,CH ; copy hours + mov [BX].tim_hour,AX ; and store into result array + mov AL,CL ; copy minutes + mov [BX].tim_min,AX ; and store into result array + mov AL,DH ; copy seconds + mov [BX].tim_sec,AX ; and store into result array + mov AL,DL ; copy hundredths + mov [BX].tim_hnds,AX ; and store into result array + + pop BP + ret +get_time endp +;************************************************************************* +; Link to Delete a file support +;************************************************************************* + public delete +delete proc near + call dos%del + ret +delete endp +;************************************************************************* +; Link to Copy a file support +;************************************************************************* + public copy_fil +copy_fil proc near + call dos%copy + ret +copy_fil endp +;************************************************************************* +; Link to Rename a file support +;************************************************************************* + public rename +rename proc near + call dos%ren + ret +rename endp +;************************************************************************* +; Link to file size support +;************************************************************************* + public filesize +filesize proc near + call dos%size + ret +filesize endp +;************************************************************************* +; Link to Change directory support +;************************************************************************* + public chgdir +chgdir proc near + call dos%cd + ret +chgdir endp +;************************************************************************* +; Link to Change drive support +;************************************************************************* + public chgdrv +chgdrv proc near + call dos%drv + ret +chgdrv endp +; + public mov_fptr +mov_fptr proc near + call mov%fptr + ret +mov_fptr endp + + +prog ends + end + \ No newline at end of file diff --git a/msdos1.asm b/msdos1.asm new file mode 100644 index 0000000..35e429b --- /dev/null +++ b/msdos1.asm @@ -0,0 +1,88 @@ +;*************************************** +;* MS-DOS Utilities * +;* * +;* (C) Copyright 1984 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 21 June 1984 * +;* Last Modification: 21 June 1984 * +;*************************************** + +MSDOS equ 021h ; MS-DOS interrupt number +GETDATE equ 02Ah ; "get_date" function request id +GETTIME equ 02Ch ; "get_time" function request id + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +get_args struc + dw ? ; caller's BP + dw ? ; return address +get_ary dw ? ; pointer to result array +get_args ends + +date_fmt struc ; format of data returned by get_date() +dat_mon dw ? ; month +dat_day dw ? ; day +dat_year dw ? ; year +date_fmt ends + +time_fmt struc ; format of data returned by get_time() +tim_hour dw ? ; hour +tim_min dw ? ; minute +tim_sec dw ? ; seconds +tim_hnds dw ? ; hundredths +time_fmt ends + + public get_date +get_date proc near + push BP ; save caller's BP + mov BP,SP ; establish operand addressability + + mov AH,GETDATE ; load "get_date" service call id + int MSDOS ; request service from MS-DOS + mov BX,[BP].get_ary ; load pointer to result array + xor AX,AX ; clear AX + mov AL,DH ; copy month, and + mov [BX].dat_mon,AX ; store into result array + xor DH,DH ; clear high order byte of DX + mov [BX].dat_day,DX ; store day into result array + mov [BX].dat_year,CX ; store year into result array + + pop BP ; restore caller's BP + ret +get_date endp + + public get_time +get_time proc near + push BP ; save caller's BP + mov BP,SP ; establish operand addressability + + mov AH,GETTIME ; load "get_time" service call id + int MSDOS ; request service from MS-DOS + mov BX,[BP].get_ary ; load pointer to result array + xor AX,AX ; clear AX + mov AL,CH ; copy hours + mov [BX].tim_hour,AX ; and store into result array + mov AL,CL ; copy minutes + mov [BX].tim_min,AX ; and store into result array + mov AL,DH ; copy seconds + mov [BX].tim_sec,AX ; and store into result array + mov AL,DL ; copy hundredths + mov [BX].tim_hnds,AX ; and store into result array + + pop BP + ret +get_time endp + +prog ends + end + + \ No newline at end of file diff --git a/newpcs/autocomp.s b/newpcs/autocomp.s new file mode 100644 index 0000000..ed3a0e9 --- /dev/null +++ b/newpcs/autocomp.s @@ -0,0 +1,19 @@ +(AUTOLOAD-FROM-FILE + (%SYSTEM-FILE-NAME "COMPILER.FSL") + '(CREATE-SCHEME-MACRO %EXPAND-SYNTAX-FORM PCS-MACRO-EXPAND + PCS-SIMPLIFY PCS-CLOSURE-ANALYSIS PCS-GENCODE PCS-POSTGEN + PCS-PRINCODE PCS-ASSEMBLER LOAD COMPILE-FILE %COMPILE-TIMINGS + %COMPILE COMPILE PCS-COMPILE-TO-AL PCS-EXECUTE-AL OPTIMIZE! + PCS-CHK-ID PCS-CHK-LENGTH= PCS-CHK-LENGTH>= PCS-CHK-BVL + PCS-CHK-PAIRS PCS-CHK-BVAR EXPAND-MACRO EXPAND-MACRO-1 EXPAND + INITIATE-EDWIN EDWIN %PCS-STL-DEBUG-FLAG %PCS-STL-HISTORY + PCS-LOCAL-VAR-COUNT PCS-INTEGRATE-INTEGRABLES + PCS-INTEGRATE-PRIMITIVES PCS-INTEGRATE-T-AND-NIL + PCS-INTEGRATE-DEFINE PCS-DEBUG-MODE PCS-PERMIT-PEEP-1 + PCS-PERMIT-PEEP-2 PCS-VERBOSE-FLAG PCS-DISPLAY-WARNINGS PME= PSIMP= + PCG= PPEEP= PASM= EVAL PCS-DEFINE-PRIMOP PCS-PRIMOP-STD-N2 + PCS-PRIMOP-APPEND* PCS-PRIMOP-+ PCS-PRIMOP-- PCS-PRIMOP-* + PCS-PRIMOP-/ PCS-PRIMOP-VECTOR PCS-PRIMOP-LIST PCS-PRIMOP-LIST* + PCS-PRIMOP-MAKE-VECTOR PCS-PRIMOP-IO-1 PCS-PRIMOP-IO-2 + PCS-DEFINE-OPCODE) + USER-GLOBAL-ENVIRONMENT) \ No newline at end of file diff --git a/newpcs/autoprim.s b/newpcs/autoprim.s new file mode 100644 index 0000000..d57a1f5 --- /dev/null +++ b/newpcs/autoprim.s @@ -0,0 +1,19 @@ +(AUTOLOAD-FROM-FILE + (%SYSTEM-FILE-NAME "PRIMOPS.FSL") + '(< <= <=? <> <>? >= >=? >? ABS ASSOC ASSQ ASSV ATOM? CAAAR + CAADR CAAR CADAR CADDDR CADDR CADR CAR CDAAR CDADR CDAR CDDAR CDDDR + CDDR CDR CEILING CHAR->INTEGER CHAR-CICHAR INTEGER? LAST-PAIR LENGTH + LIST-TAIL MAKE-PACKED-VECTOR MEMBER MEMQ MEMV MINUS NEGATIVE? NOT + NUMBER? OBJECT-HASH OBJECT-UNHASH ODD? PAIR? PORT? POSITIVE? + PRINT-LENGTH PROC? PROPLIST PUTPROP QUOTIENT RATIONAL? REAL? + REMAINDER REMPROP RESET REVERSE! ROUND SCHEME-RESET SET-CAR! + SET-CDR! STRING->SYMBOL STRING->UNINTERNED-SYMBOL STRING-FILL! + STRING-LENGTH STRING-REF STRING-SET! STRING? SUBSTRING + SUBSTRING-FIND-NEXT-CHAR-IN-SET SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET + SYMBOL->STRING SYMBOL? THE-ENVIRONMENT TRUNCATE VECTOR-FILL! + VECTOR-LENGTH VECTOR-REF VECTOR-SET! VECTOR? WINDOW-SAVE-CONTENTS + WINDOW-RESTORE-CONTENTS ZERO?) + USER-GLOBAL-ENVIRONMENT) \ No newline at end of file diff --git a/newpcs/compile.all b/newpcs/compile.all new file mode 100644 index 0000000..cd01083 --- /dev/null +++ b/newpcs/compile.all @@ -0,0 +1,322 @@ +;;; ---------------------------------------------------------------------------- +;;; +;;; Compile the compiler 6/12/87 COMPILE.ALL +;;; +;;; This file compiles all components of the PCS system which are written +;;; in Scheme except SCOOPS and EDWIN, which are managed separately. +;;; +;;; +;;; ---------------------------------------------------------------------------- + +(set! pcs-debug-mode '()) + +(fast-load (%system-file-name "pboot.fsl")) +(fast-load (%system-file-name "pp.fsl")) + +; +; The following files make up the compiler and are used to build the +; compiler.fsl and compiler.app files. +; +(define *source-compiler-autoload-files* + '("PMACROS" "PME" "PSIMP" "PCA" "PGENCODE" "PPEEP" "PASM" "PCOMP" + "PAUTO_C" "PAUTO_R" "POPCODES")) + +; +; The following files make up the required "kernal" of scheme. +; +(define *source-kernal-files* + '("PSTD" "PSTD2" "PIO" "PCHREQ" "PDEBUG" "PSTL" "AUTOCOMP")) + +; +; The following is a combination of the compiler and kernal used to +; build the compiler.app file. +; +(define *source-compiler-files* + (append *source-compiler-autoload-files* *source-kernal-files*)) +; +; The following files must be re-compiled for the runtime only system. +; Basically all but PRIMOPS contain code with integrables which must be +; recompiled to run in a compiler-less environment. PRIMOPS must be +; created from POPCODES to create closure definitions for all the scheme +; primitives. +; +(define *runtime-compiler-files* + '("PSTD" "PSTD2" "PIO" "PCHREQ" "PRIMOPS")) +; +; The following files are the autoload files which can be used for +; either the compiler or runtime system. +; +(define *autoload-files* + '("PADVISE" "PGR" "PP" "PBOOT" "PDOS" "PFUNARG" "PSORT" + "EDIT" "PNUM2S" "PDEFSTR" "PMATH" "PWINDOWS" "PINSPECT" "OLDPMATH")) + +; +; Take input file containing primitive definitions and produce +; output file of procedures +; +(define build-primops + (lambda (input-file output-file) + (letrec + ((infile (open-input-file input-file)) + (outfile (open-output-file output-file)) + (vars '(a b c d e f g h i j)) + (build-primop + (lambda (op numrands) + (if (and (number? numrands) + (not (char=? (string-ref (symbol->string op) 0) #\%))) + (let ((bvl (list-tail vars (- (length vars) numrands)))) + (princ " " 'console) + (display op) + (newline outfile) + (pp `(define ,op (lambda ,bvl (,op . ,bvl))) outfile) + (newline outfile))))) + (build-prims + (lambda (lst) + (if (null? lst) + 'ok + (if (eq? (caar lst) 'pcs-define-primop) + (begin + (build-primop (cadr (cadar lst)) (caddar lst)) + (build-prims (cdr lst))))))) + (read-rec + (lambda (r) + (cond ((eof-object? r) + 'OK) + ((and (pair? r) + (eq? (car r) 'begin) + (eq? (car (cadr r)) 'pcs-define-primop)) + (build-prims (cdr r)) + (read-rec (read infile))) + (else + (read-rec (read infile))))))) + + (newline 'console) + (princ "[Building " 'console) + (princ output-file 'console) + (princ " from " 'console) + (princ input-file 'console) + (princ "]" 'console) + (newline 'console) + + (read-rec (read infile)) + (close-input-port infile) + (close-output-port outfile)))) + +; +; Take list of files, extract all procedure definition names, and build an +; autoload list. Place the autoload definitions in fileout; the autoload +; reference file (which is also placed in the autoload definition) is +; autoref +; +(define build-auto + (lambda (filelist fileout autoref) + (letrec + ((inport '()) + (autolist '()) + (inspect-begin + (lambda (lst) + (if (null? lst) + 'ok + (if (and (pair? (car lst)) + (eq? (caar lst) 'define)) + (begin + (set! autolist (cons (if (atom? (cadar lst)) + (cadar lst) + (car (cadar lst))) + autolist)) + (display (car autolist)) (display " ") + (inspect-begin (cdr lst))))))) + (read-rec + (lambda (record) + (cond ((eof-object? record) + 'OK) + ((pair? record) + (if (eq? (car record) 'define) + (begin + (set! autolist + (cons (if (atom? (cadr record)) + (cadr record) + (car (cadr record))) + autolist)) + (display (car autolist)) (display " ")) + ;else + (if (eq? (car record) 'begin) + (inspect-begin (cdr record)))) + (read-rec (read inport))) + (else + (read-rec (read inport)))))) + (read-files + (lambda (list) + (if (null? list) + 'ok + (begin + (set! inport (open-input-file + (string-append (car list) ".s"))) + (newline) + (display (car list)) (display ": ") + (read-rec (read inport)) + (close-input-port inport) + (read-files (cdr list)))))) + ) + + (display "building autoload list in file : ") + (write (string-append fileout ".s")) + (newline) + + (read-files filelist) + + (with-output-to-file (string-append fileout ".s") + (lambda () + (pp `(autoload-from-file + (%system-file-name ,autoref) + ',(reverse autolist) + user-global-environment)))) + + *the-non-printing-object*))) + +; +; compile the given file, writing to appropriate object file +; +(define godoit + (lambda (file) + (let ((src (string-append (filename-sans-extension file) + (if (not (string-null? + (extension-sans-filename file))) + (extension-sans-filename file) + ".S"))) + (obj (string-append (filename-sans-extension file) + (case compiling-compiler? + (#!false ".RTO") + (else ".SO"))))) + (newline 'console) + (princ "[Compiling " 'console) + (princ src 'console) + (princ " to " 'console) + (princ obj 'console) + (princ "]" 'console) + (newline 'console) + (if (file-exists? src) + (begin + (gc) + (pcs-compile-file src obj) + (set! files-compiled (cons src files-compiled))) + (begin + (writeln "File not found!") + (set! files-not-compiled (cons src files-not-compiled)))) + ))) + +(define *this-file* "COMPILE.ALL") + +(define *do-files* nil) ;files that get compiled this time round + +(define compiling-compiler?) ;if true, compiling the runtime only + +(for-each (lambda (string) ; Make PCS-INITIAL-ARGUMENTS uppercase + (let loop ((n 0)) + (when (char 7) ;beep + "The file COMPILE.ALL is meant to be invoked ") + (writeln "from the PCS command line only.") + (reset))) + + +(set! pcs-initial-arguments ; remove invocation file + (cdr pcs-initial-arguments)) + + +(let ((request ; classify request + (string->symbol + (car pcs-initial-arguments))) + (print (lambda x + (newline) + (for-each display x)))) + (set! compiling-compiler? request) + (case request + (? + (print "To compile the compiler, invoke with:") + (print " pcs " *this-file* " ? - this display") + (print " pcs " *this-file* " /src - all of source compiler") + (print " pcs " *this-file* " /src file ... - compile given src files") + (print " pcs " *this-file* " /rt - all of runtime compiler") + (print " pcs " *this-file* " /rt file ... - compile given runtime files") + (print " pcs " *this-file* " /auto - all autoload files") + (print " pcs " *this-file* " /auto file ... - compile given autoload files") + (print " pcs " *this-file* " /stl - compile STL.S file") + (print " pcs " *this-file* " /noload file ... - compile without incremental load") + (newline) + (reset)) + (/src + (print "Compiling source compiler.") + (newline) + (if (cdr pcs-initial-arguments) + (set! *do-files* (cdr pcs-initial-arguments)) + (set! *do-files* *source-compiler-files*))) + (/rt + (set! compiling-compiler? #!false) + (print "Compiling runtime compiler.") + (newline) + (if (cdr pcs-initial-arguments) + (set! *do-files* (cdr pcs-initial-arguments)) + (set! *do-files* *runtime-compiler-files*))) + (/auto + (print "Compiling autoload files.") + (newline) + (if (cdr pcs-initial-arguments) + (set! *do-files* (cdr pcs-initial-arguments)) + (set! *do-files* *autoload-files*))) + (/noload + (print "Compiling arbitrary files without executing them.") + (newline) + (set! *do-files* (cdr pcs-initial-arguments))) + (else + (error (string-append "Bad request to " *this-file*) request)))) + + +(if (not compiling-compiler?) ; if runtime, treat define-integrable + (begin ; as if it were define + (remprop 'define-integrable 'pcs*macro) + (macro define-integrable + (lambda (e) + `(define ,@(cdr e)))))) + +(define files-compiled '()) +(define files-not-compiled '()) + +;;; +;;; Compile each file supplied by *do-files*. +;;; If PRIMOPS is encountered, it must be built from POPCODES, and +;;; an autoload definition created for AUTOPRIM.FSL. +;;; If AUTOCOMP is encountered, create autoload definition in +;;; AUTOCOMP.FSL, referencing COMPILER.FSL +(for-each + (lambda (file) + (cond + ((string-ci=? (filename-sans-extension file) "PRIMOPS") + (build-primops "POPCODES.S" "PRIMOPS.S") ;create PRIMOPS.S + (build-auto (list "PRIMOPS") "AUTOPRIM" "PRIMOPS.FSL") ;create AUTOPRIM.S + (godoit "AUTOPRIM")) ; and compile it + ((string-ci=? (filename-sans-extension file) "AUTOCOMP") + (build-auto ;create AUTOCOMP.S + *source-compiler-autoload-files* file "COMPILER.FSL")) + ) + (godoit file)) ;compile file + *do-files*) + +(writeln "Files compiled: " (reverse! files-compiled)) +(writeln "Files not compiled: " (reverse! files-not-compiled)) + +; it would be nicer if PCS could set the DOS exit code +(if (not files-not-compiled) + (exit)) + \ No newline at end of file diff --git a/newpcs/edit.s b/newpcs/edit.s new file mode 100644 index 0000000..2ea16e2 --- /dev/null +++ b/newpcs/edit.s @@ -0,0 +1,835 @@ + +; -*- Mode: Lisp -*- Filename: edit.s + +; Last Revision: 13-Sep-85 1230ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; Paul Kristoff ; +; ; +; The Scheme Structure Editor ; +; ; +;--------------------------------------------------------------------------; + + +(define edit + (letrec ((read-eval-print-loop + (letrec ((read-command + (lambda () + (print 'EDIT->) + (set! buffer (read)) + (if (atom? buffer) + (set! buffer (list (list buffer))) + (if (atom? (car buffer)) + (set! buffer (list buffer)))))) + (do-command + (lambda () + (if (or (number? (car command)) + (eq? (car command) '*)) + (move (car command)) + (case (car command) + ((?) (print + (print-depth-length fp 2 10))) + ((P) (print fp)) + ((??) (pp + (print-depth-length fp 2 10))) + ((PP) (pp fp)) + ((N) (next)) + ((PR) (previous)) + ((B) (beginning)) + ((T) (top)) + ((F) (find (cadr command))) + ((IB) (insert-before + (cadr command) + (caddr command))) + ((IA) (insert-after + (cadr command) + (caddr command))) + ((SB) (splice-before + (cadr command) + (caddr command))) + ((SA) (splice-after + (cadr command) + (caddr command))) + ((D) (delete (cadr command))) + ((DP) (delete-parentheses + (cadr command))) + ((AP) (add-parentheses + (cadr command) + (caddr command))) + ((S) (substitute + (cadr command) + (caddr command))) + ((R) (replace + (cadr command) + (caddr command))) + ((PS) (ps)) + ((MAC?) (mac? (cadr command))) + ((MAC) (create-ed-macro + (cadr command) + (caddr command))) + ((Q) (set! done? t)) + (else (if (ed-macro? (car command)) + (expand-mac command) + (begin + (newline) + (set! buffer nil) + (writeln + " ? Unknown command: " + command)))) + )))) + (mac? + (lambda (name) + (let ((temp (ed-macro? name))) + (if (null? temp) + (begin (writeln name " is not a macro.") + nil) + (pp (list 'mac (list name (car temp)) + (cdr temp))))))) + (ed-macro? + (lambda (name) + (and (symbol? name) + (getprop name 'ed*macro)))) + (expand-mac + (lambda (com) + (let* ((x (getprop (car com) 'ed*macro)) + (eem (expand-ed-macro + (cdr com) + (car x) + (cdr x)))) + (if (eq? eem 'error) + (begin (set! buffer nil) + (writeln " ? Error with macro" + command)) + (set! buffer + (append eem buffer)))))) + (create-ed-macro + (lambda (name&nargs expan) + (putprop (car name&nargs) + (cons (cadr name&nargs) + expan) + 'ed*macro))) + (expand-ed-macro + (lambda (args nargs expan) + (letrec + ((loop + (lambda (expan) + (cond ((null? expan) nil) + ((atom? expan) + (let ((n (arg? expan))) + (if n + (list-ref args (-1+ n)) + expan))) + ((atom? (car expan)) + (let ((n (arg? (car expan)))) + (cons (if n + (list-ref args + (-1+ n)) + (car expan)) + (loop (cdr expan))))) + (t (cons (loop (car expan)) + (loop (cdr expan))))))) + ) + (if (= (length args) nargs) + (loop expan) + 'error)))) + ) + (lambda () + (if (not (memq (car command) '(P ? PP ??))) + (print (print-depth-length fp 2 10))) + (if (not done?) + (begin (read-command) + (do () + ((null? buffer)) + (set! command (car buffer)) + (when (atom? command) + (set! command (list command))) + (set! buffer (cdr buffer)) + (do-command)) + (read-eval-print-loop)) + (begin (top) fp))))) + + + +;--------------------------------------------------------------------; +; MOVE ; +; Argument: integer or * ; +; Move repositions the fp to be the nth element of the current ; +; fp. If an integer is positive the nth element will be from ; +; the left. If the number is too large then the fp is moved to ; +; last element from the left. If negative the nth element will ; +; be from the right. If the absolute value of the number is ; +; larger than the number of elements in the fp, then the fp is ; +; repositioned to the 1st element from the left. If the the ; +; argument is *, the fp is repositioned to be the cdr of the ; +; cons cell of the fp. ; +;--------------------------------------------------------------------; + + (move + (let ((stop (lambda () + (newline) + (writeln " ? Cannot do a Move on an atom.")))) + (lambda (n) + (cond ((atom? fp) (stop)) + ((eq? n '*) + (begin (push fp '*) + (set! fp (cdr (last-pair fp))) + fp)) + (t (let ((num (correct-position n))) + (cond ((null? n) (circular num)) + ((<= num 0) (push fp 1) + (set! fp (car fp))) + (t (let ((smart-list + (smart-list-ref + fp (-1+ num)))) + (push fp + (- num (cdr smart-list))) + (set! fp (car smart-list)) + fp))))))))) + +;--------------------------------------------------------------------; +; BEGINNING ; +; No arguments ; +; Repositions the fp to be the parent of the current fp ; +;--------------------------------------------------------------------; + (beginning + (let ((stop (lambda () + (newline) + (writeln " ? Already at top level.")))) + (lambda () + (if (at-top-level?) + (stop) + (let ((stack-frame (pop))) + (set! fp (fp-part stack-frame)) + fp))))) + +;--------------------------------------------------------------------; +; NEXT ; +; No Arguments ; +; Moves the fp to be the next element to the right of the parent ; +; of the current fp. If the fp is pointing to the last element, ; +; the fp remains the same. ; +;--------------------------------------------------------------------; + + (next + (let ((stop (lambda () + (newline) + (writeln + " ? There is no Next from this position"))) + (stop1 + (lambda () + (newline) + (writeln + " ? Can't execute Next command at top level")))) + (lambda () + (if (at-top-level?) + (stop1) + (let ((stack-frame (pop))) + (set! fp (fp-part stack-frame)) + (move (if (eq? (element-part stack-frame) '*) + (begin (stop) '*) + (1+ (element-part stack-frame)))) + fp))))) + +;--------------------------------------------------------------------; +; PREVIOUS ; +; No Arguments ; +; Repositions the fp to be the previous element of the parent of ; +; the current fp. If already at the first element of the fp, then ; +; the fp remains the same. ; +;--------------------------------------------------------------------; + (previous + (let ((stop (lambda () + (newline) + (writeln + " ? There is no Previous from this position"))) + (stop1 (lambda () + (newline) + (writeln + " ? Can't execute Previous at top level")))) + (lambda () + (if (at-top-level?) + (stop1) + (let ((stack-frame (pop))) + (set! fp (fp-part stack-frame)) + (move (cond ((eq? (element-part stack-frame) '*) + (begin (stop) '*)) + ((= (element-part stack-frame) 1) (stop) 1) + (t (-1+ (element-part stack-frame))))) + fp))))) + +;--------------------------------------------------------------------; +; TOP ; +; No arguments ; +; Sets the fp to point to the car of very-top. Resets the stack. ; +;--------------------------------------------------------------------; + (top + (lambda () + (set! fp (car very-top)) + (set! stack initial-stack) + )) +;--------------------------------------------------------------------; +; FIND ; +; Can take an argument ; +; Searches beginning with the FP (not including the FP) until the ; +; it either finds the pfv (using equal?) or the whole stack is ; +; popped. If it is found the FP is moved to that point. If is ; +; it is not the FP and STACK remain the same. The value maybe ; +; inside the FP. ; +;--------------------------------------------------------------------; + (find + (letrec ((find-next + (lambda () + (cond ((equal? fp pfv) (set! found? t)) + ((atom? fp) (get-next-element)) + (t (move 1) + (find-next))))) + (get-next-element + (let ((stop (lambda () + (newline) + (writeln " ? Did not find " + pfv)))) + (lambda () + (if (at-top-level?) + (stop) + (let ((stack-frame (pop))) + (let ((tfp (fp-part stack-frame)) + (tel (element-part + stack-frame))) + (if (eq? tel '*) + (get-next-element) + (let ((next-element + (list-ref-* tfp tel))) + (push tfp + (if (eq? (cdr next-element) + '*) + '* + (1+ tel))) + (set! fp + (car next-element)) + (find-next))) + )))))) + (temp-stack nil) + (temp-fp nil) + (found? nil) + (pfv '**unbound**) + ) + (lambda v + (if (not (null? (car v))) + (set! pfv (car v))) + (set! found? nil) + (set! temp-stack stack) + (set! temp-fp fp) + (if (atom? fp) ; allows find next if fp is + (get-next-element) ; equal to the pfv + (begin (move 1) (find-next))) + (if (not found?) + (let ((par (parent stack))) + (set! stack temp-stack) + (set! fp temp-fp))) + fp))) +;--------------------------------------------------------------------; +; REPLACE ; +; arguments n: The element being replaced (nth element of the FP). ; +; v: The value the nth element will replace. ; +; Replace will replace the nth element of the FP with v. n can be ; +; either negative or positive. If too large an error is indicated. ; +;--------------------------------------------------------------------; + (replace + (lambda (n v) + (cond ((eq? n '*) (set-cdr! (last-pair fp) v)) + ((not (number? n)) + (newline) + (writeln " ? Non-number or non-* to Replace: " n)) + ((= n 0) (correct-stack v) + (set! fp v)) + (t (let ((num (correct-position n))) + (if (null? num) + (circular-error n) + (let ((sc (smart-list-tail + fp + (-1+ num)))) + (if (atom? sc) + (not-enough-elements-error n) + (set-car! sc v))))))))) +;--------------------------------------------------------------------; +; SUBSTITUTE ; +; arguments for : The value searched for. ; +; this: The value that replaces the value searched for ; +; Searches the FP for 'for'. It replaces all occurrences of 'for' ; +; with 'this'. If none are found it will indicate that. ; +;--------------------------------------------------------------------; + (substitute + (lambda (for this) + (letrec ((found? nil) + (subst + (lambda (l) + (cond ((null? l) nil) + ((equal? for l) (set! found? t) this) + ((atom? l) l) + (t (cons (subst (car l)) + (subst (cdr l))))))) + ) + (set! fp (subst fp)) + (if (not found?) + (begin (newline) + (writeln " ? Can't find " for)) + (correct-stack fp)) + fp))) + (delete + (lambda (n) + (cond ((eq? n '*) (set-cdr! (last-pair fp) nil)) + ((not (number? n)) + (newline) + (writeln " ? Non-number or non-* to Delete: " n)) + ((zero? n) (set! fp nil) (correct-stack fp)) + (t (let ((num (correct-position n))) + (cond ((null? num) (circular-error n)) + ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't delete " + n " element")) + ((= num 1) + (set! fp (cdr fp)) + (correct-stack fp)) + (t (let ((sc (smart-list-tail fp (- num 2))) + (scc (smart-list-tail fp num))) + (if (and (atom? scc) + (not (null? scc))) ;PRK 53085 + (not-enough-elements-error n) + (set-cdr! sc scc)))))))))) +;--------------------------------------------------------------------; +; DELETE PARENTHESES ; +; argument n: The nth element of the FP ; +; Deletes the parentheses from around the nth element of the FP. ; +; The nth element must be a list otherwise an error will occur. n ; +; maybe either negative or positive. ; +;--------------------------------------------------------------------; + (delete-parentheses + (lambda (n) + (letrec ((stop1 + (lambda () + (newline) + (writeln + " ? Can't delete parentheses for this position " + n))) + (stop2 (lambda () + (newline) + (writeln " ? Element is not a list"))) + ) + (if (and (number? n) (not (zero? n))) + (let* ((num (correct-position n))) + (if (null? num) + (circular-error n) + (let ((elem (smart-list-ref fp (-1+ num))) + (next-elem (smart-list-tail fp num)) + ) + (when (eq? next-elem '*atom-returned*) + (set! next-elem '())) + (cond ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't delete " + n " element.")) + ((not (zero? (cdr elem))) + (not-enough-elements-error n)) + ((not (list? (car elem))) + (stop2)) + ((= num 1) + (set! fp (append! (car elem) next-elem)) + (correct-stack fp)) + (t (set-cdr! (list-tail fp (- num 2)) + (append! (car elem) next-elem))))))) + (stop1)) + ))) +;--------------------------------------------------------------------; +; ADD PARENTHESES ; +; arguments x: One or two arguments ; +; Will add parentheses from the first argument to the second ; +; argument (left to right). The first argument must be to the left ; +; or the same as the second argument. If the first argument is * or; +; 0 (zero) the second argument is ignored. ; +;--------------------------------------------------------------------; + (add-parentheses + (lambda x + (let ((m (car x))(n (cadr x))) + (cond ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't Add Parentheses")) + ((eq? m '*) + (let ((lp (last-pair fp))) + (set-cdr! lp (list (cdr lp))))) + ((not (number? m)) + (newline) + (writeln + " ? Non-number or non-* to Add Parentheses: " + m)) + ((= m 0) (set! fp (cons fp nil)) + (correct-stack fp)) + ((eq? n '*) + (let ((cm (correct-position m))) + (cond ((null? cm)(circular-error m)) + ((= cm 1) (set! fp (cons fp nil)) + (correct-stack fp)) + (t (let ((slt1 + (smart-list-tail fp (- cm 2))) + (slt2 + (smart-list-tail fp (-1+ cm)))) + (if (atom? slt2) + (not-enough-elements-error m) + (set-cdr! slt1 + (cons slt2 nil)))))))) + ((not (number? n)) + (newline) + (writeln + " ? Non-number or non-* to Add Parentheses: " + n)) + (t (let ((cm (correct-position m)) + (cn (correct-position n))) + (cond ((null? cm) (circular-error m)) + ((null? cn) (circular-error n)) + ((<= cm 0) (not-enough-elements-error m)) + ((<= cn 0) (not-enough-elements-error n)) + ((> cm cn) + (newline) + (writeln + " ? First argument, " m + " is positioned to the right of the 2nd, " n)) + (t (let ((end-fp (list-tail fp cn)) + (last-arg-tail + (smart-list-tail fp (-1+ cn)))) + (if (atom? last-arg-tail) + (not-enough-elements-error n) + (begin (set-cdr! last-arg-tail nil) + (if (= cm 1) + (begin + (set! fp + (cons fp end-fp)) + (correct-stack fp)) + (set-cdr! + (list-tail fp (- cm 2)) + (cons + (list-tail fp (-1+ cm)) + end-fp)))))))))) + )))) +;--------------------------------------------------------------------; +; SPLICE BEFORE ; +; arguments n: The nth element of the FP ; +; v: The list of values to be spliced before the nth ; +; element. ; +; Splices before the nth element of the FP, the elements in v. If ; +; v is not a list an error is indicated. ; +;--------------------------------------------------------------------; + (splice-before + (lambda (n v) + (cond ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't splice before " + n " element")) + ((or (not (number? n)) (zero? n)) + (newline) + (writeln + " ? First argument must be a non-zero integer: " + n)) + ((not (list? v)) + (newline) + (writeln " ? Second argument must be a list: " v)) + (t (let ((num (correct-position n))) + (cond ((null? num) + (circular-error n)) + ((= num 1) + (set! fp (append! v fp)) + (correct-stack fp)) + (t (let ((slt1 + (smart-list-tail fp (- num 2))) + (slt2 + (smart-list-tail fp (-1+ num)))) + (if (atom? slt2) + (not-enough-elements-error n) + (set-cdr! slt1 + (append! v slt2)))))))) + ))) +;--------------------------------------------------------------------; +; SPLICE AFTER ; +; arguments n: The nth element of the FP. ; +; v: The list of elements that are splice after the nth ; +; element. ; +; The elements of v are placed after the nth element of the FP. If ; +; v is not a list an error is indicated. ; +;--------------------------------------------------------------------; + (splice-after + (lambda (n v) + (cond ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't splice after " + n " element")) + ((or (not (number? n)) (zero? n)) + (newline) + (writeln + " ? First argument must be a non-zero integer: " + n)) + ((not (list? v)) + (newline) + (writeln " ? Second argument must be a list: " v)) + (t (let ((num (correct-position n))) + (if (null? num) + (circular-error n) + (let ((slt1 (smart-list-tail fp (-1+ num))) + (slt2 (smart-list-tail fp num))) + (if (atom? slt1) + (not-enough-elements-error n) + (set-cdr! slt1 + (append! v slt2))))))) + ))) +;--------------------------------------------------------------------; +; INSERT BEFORE ; +; arguments num: The nth element of the FP ; +; v : The value being placed before the nth element ; +; Makes sure that the v can be inserted the calls splice-before ; +; with num and (list v). ; +;--------------------------------------------------------------------; + (insert-before + (lambda (num v) + (cond ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't insert before " + n " element")) + (t (splice-before num (cons v nil)))))) +;--------------------------------------------------------------------; +; INSERT AFTER ; +; arguments num: The nth element of the FP ; +; v : The value being placed after the nth element ; +; Makes sure that the v can be inserted the calls splice-after ; +; with num and (list v). ; +;--------------------------------------------------------------------; + (insert-after + (lambda (num v) + (cond ((atom? fp) + (newline) + (writeln + " ? FP is an atom, can't insert after " + n " element")) + (t (splice-after num (cons v nil)))))) +;--------------------------------------------------------------------; +; ; +; Help Functions ; +; ; +;--------------------------------------------------------------------; + + (push + (lambda (l pos) + (set! stack (cons (list* l pos) stack)))) + + (pop + (lambda () + (if (null? (cdr stack)) + 'cannot-pop-stack + (begin0 (car stack) + (set! stack (cdr stack)))))) + + (fp-part car) + + (element-part cdr) + ;----------------------------------------------------------; + ; Print depth length ; + ; It will return a list with depth of print-level and ; + ; length of print-length. It will replace all levels ; + ; lower than print-level with # and all elements further ; + ; than print-length with ... ; + ;----------------------------------------------------------; + + (print-depth-length + (letrec ((p1 0) + (loop + (lambda (l lev len) + (cond ((<= len 0) '(...)) + ((atom? l) l) + ((<= lev 0) '#\#) + ((atom? (car l)) + (cons (car l) + (loop (cdr l) lev (-1+ len)))) + (t (cons (loop (car l) (-1+ lev) p1) + (loop (cdr l) lev (-1+ len))))))) + ) + (lambda (l print-level print-length) + (set! p1 print-length) + (loop l print-level print-length) ))) + + (list-length ; Gives list-length while checking for + (lambda (l) ; circular lists. Returns nil + (letrec ((loop (lambda () ; if circular list is found + (cond ((atom? fast) n) + ((atom? (cdr fast)) (+ n 1)) + ((and (eq? fast slow) (> n 0)) nil) + (t (set! fast (cddr fast)) + (set! slow (cdr slow)) + (set! n (+ n 2)) + (loop))))) + (n 0) + (fast l) + (slow l)) + (loop)))) + + (correct-position ; If number is negative, translates it + (lambda (n) ; the equivalent positive number. + (if (< n 0) + (+ (list-length fp) (1+ n)) + n))) + + ;----------------------------------------------------------; + ; Smart-list-ref ; + ; Returns a pair. The first of which is the list-ref of ; + ; l. The second is the number left over. This number ; + ; will be zero unless the number is larger than the number; + ; of elements in the list. Then it will show the number ; + ; left and return the last element. ; + ;----------------------------------------------------------; + (smart-list-ref + (lambda (l n) + (cond ((atom? l) nil) + ((atom? (cdr l)) (cons (car l) n)) + ((zero? n) (cons (car l) 0)) + (t (smart-list-ref (cdr l) (-1+ n)))))) + + (at-top-level? + (lambda () (null? (cdr stack)))) + ;----------------------------------------------------------; + ; Correct-stack ; + ; Corrects the parent of the FP when the FP is changed ; + ; with a set! instead of set-car! or set-cdr! ; + ;----------------------------------------------------------; + + (correct-stack + (lambda (l) + (let ((par (parent stack))) + (if (eq? (element-part par) '*) + (if (atom? l) + (set-cdr! (last-pair (fp-part par)) l) + (let ((stack-frame (pop))) + (set! fp (fp-part stack-frame)) + (set-cdr! (last-pair fp) l))) + (set-car! (if (= (element-part par) 1) + (fp-part par) + (list-tail (fp-part par) + (-1+ (element-part par)))) + l))))) + + (list? + (lambda (l) + (and (pair? l) + (null? (cdr (last-pair l)))))) + + ;----------------------------------------------------------; + ; List-ref-* ; + ; Used in Find. It is set up to know about the *th ; + ; position. It counts the * as another element. Other ; + ; than this, it is just like smart-list-ref. ; + ;----------------------------------------------------------; + (list-ref-* + (lambda (l n) + (cond ((atom? l) (cons l '*)) + ((zero? n) (cons (car l) 0)) + (t (list-ref-* (cdr l) (-1+ n)))))) + + (parent car) + + ;----------------------------------------------------------; + ; Smart-list-tail ; + ; This is used in the modifying commands. It allows the ; + ; calling function to figure out if there is an nth ; + ; element. An atom is returned if it there are not n ; + ; elements. The value of this command is used in set-car!; + ; and set-cdr!. Thus it cannot be an atom. ; + ;----------------------------------------------------------; + (smart-list-tail + (letrec ((loop + (lambda (l n) + (cond ((zero? n) l) + ((atom? l) '**atom-returned**) ;PRK 53085 + (t (loop (cdr l) (-1+ n))))))) + (lambda (l n) + (if (< n 0) + '**atom-returned** + (loop l n))))) + + (not-enough-elements-error + (lambda (n) + (newline) + (writeln " ? There are not " n " elements"))) + + (circular-error + (lambda (n) + (newline) + (writeln + " ? FP is a circular list, can't use negative numbers: " + n))) + + (arg? + (lambda (a) + (let ((x (explode a))) + (if (eq? (car x) '#\#) + (if (number-range? (cdr x)) + (symbols->number (cdr x) 10 0) + #!false) + #!false)))) + + (number-range? + (lambda (l) + (if (null? l) + #!true + (let ((a (symbol->ascii (car l)))) + (if (and (> a 47) (< a 58)) + (number-range? (cdr l)) + #!false))))) + + (symbols->number + (lambda (l b n) + (if (null? l) + 0 + (+ (symbols->number (cdr l) b (1+ n)) + (* (expt b n) + (- (symbol->ascii (car l)) 48)))))) + +;--------------------------------------------------------------------; +; ; +; Variables ; +; ; +;--------------------------------------------------------------------; + + (very-top nil) + (initial-stack nil) + (fp nil) + (stack nil) + (command nil) + (done? nil) + (buffer nil) + + +;--------------------------------------------------------------------; +; ; +; Debugging Functions ; +; ; +;--------------------------------------------------------------------; + + (ps (lambda () (print (print-depth-length stack 4 10)))) + + + ) + + (lambda (l) + (set! done? nil) + (set! fp l) + (set! very-top (list fp)) + (set! initial-stack (list (list* very-top 1))) + (set! stack initial-stack) + (read-eval-print-loop)))) + + \ No newline at end of file diff --git a/newpcs/edwin.ini b/newpcs/edwin.ini new file mode 100644 index 0000000..7b42fee --- /dev/null +++ b/newpcs/edwin.ini @@ -0,0 +1,128 @@ +;;; +;;; This is a sample EDWIN.INI file to demonstrate how to customize EDWIN for +;;; both keyboard input and display output. When placed in the same directory +;;; as PC Scheme, it will be loaded automatically the first time EDWIN is +;;; entered +;;; + + +;;; +;;; The following code is an example of customizing the color of Edwin's +;;; three windows; the editing buffer, the mode line, and the echo area. +;;; In the example, the text attribute of each window is set to a color +;;; that is different from the other windows. I'm not suggesting that you +;;; will like the colors, just that they are different. +;;; +;;; In order to write a general example (that will work for either TI or +;;; IBM machines), the PC Scheme variable PCS-MACHINE-TYPE is examined and +;;; the colors set according to the type of machine. TI is type 1 and the +;;; character-enable bit must be set by adding 8 to the color. Feel free to +;;; experiment with the code to determine a configuration that you are +;;; comfortable with +;;; +;;; +;;;(let ((type (if (eq? 1 pcs-machine-type) 8 0))) +;;; (window-set-attribute! buffer-screen 'text-attributes (+ type 7)) +;;; (window-set-attribute! modeline-screen 'text-attributes (+ type 6)) +;;; (window-set-attribute! typein-screen 'text-attributes (+ type 3))) + + +;;; +;;; The following code is used to customize your keyboard for use with EDWIN. +;;; It allows you to define new key sequences in terms of existing EDWIN key +;;; sequences. REMAP-EDWIN-KEY is a macro which takes two arguments, the new +;;; key sequence you wish to define, and the existing EDWIN key sequence. The +;;; arguments may be either a character or a list of characters representing +;;; the key codes for your particular machine. The key codes for your machine +;;; can be found in the technical reference manual for your machine, or by +;;; executing the function GET-KEYCODE. GET-KEYCODE allows you to enter any +;;; single key sequence, and returns the corresponding code to use with +;;; REMAP-EDWIN-KEY. +;;; +;;; Remember that EDWIN commands (represented by certain key sequences) are of +;;; 5 basic types; simple, control, meta, meta-control, and control-x. SIMPLE +;;; commands are single character commands (normally just insert into the +;;; buffer), CONTROL commands are entered by typing the ctrl key while pressing +;;; another character, META commands are entered by pressing either the escape +;;; or ctrl-z keys and then typing another character, META-CONTROL commands are +;;; entered by typing the meta prefix and then a ctrl key sequence, and +;;; CONTROL-X commands are entered by typing ctrl-x followed by another key +;;; sequence. +;;; +;;; The key codes for CTRL key sequences varies depending on the control key +;;; sequence entered. Some codes returned from the keyboard are extended key +;;; codes, or an extended code of 0 followed by the key code. For example, the +;;; key code returned from pressing CTRL-@ is a two key code of the extended +;;; key code (0) followed by the integer 3; this is represented in the following +;;; code as the list (extended-char (integer->char 3)). Use GET-KEYCODE to +;;; obtain the key codes necessary to remap keys via EDWIN-REMAP-KEY. + + +(define meta-char (integer->char 27)) ; Key code for Edwin META key +(define ctrl-x (integer->char 24)) ; Key code for Edwin CTRL-X + +(define extended-char (integer->char 0)) ; Denotes an extended key code + +; +; This is a helper function which returns the key codes for any single +; key sequence. It is useful in determining the key codes returned from +; your particular machine and can be used to determine the arguments for +; REMAP-EDWIN-KEY +; +(define (get-keycode) + (let ((code (read-char))) + (if (char=? code (integer->char 0)) + `(list extended-char (integer->char ,(char->integer (read-char)))) + `(integer->char ,(char->integer code))))) + +; +; Redefine keys. The following will work for either TI or IBM machines. +; + +(remap-edwin-key + (list extended-char (integer->char 59)) ;New Key = F1 + (integer->char 22)) ;Old Key = CNTRL-V (Scroll Up) + +(remap-edwin-key + (list extended-char (integer->char 60)) ;New Key = F2 + (list meta-char #\V)) ;Old key = Meta-V (Scroll Down) + +(remap-edwin-key + (list extended-char (integer->char 61)) ;New Key = F3 + (list extended-char (integer->char 3))) ;Old Key = CNTRL-@ (Set Mark) + +(remap-edwin-key + (list extended-char (integer->char 62)) ;New Key = F4 + (list (integer->char 24) ;Old key = CNTRL-X CNTRL-X + (integer->char 24))) ; (Xchg mark and point) + +(remap-edwin-key + (list extended-char (integer->char 63)) ;New key = F5 + (integer->char 23)) ;Old Key = CNTRL-W (Kill Region) + +(remap-edwin-key + (list extended-char (integer->char 64)) ;New key = F6 + (integer->char 25)) ;Old key = CNTRL-Y (Unkill) + +(remap-edwin-key + (list extended-char (integer->char 67)) ;New key = F9 + (list meta-char (integer->char 60))) ;Old key = META < (Go buffer top) + +(remap-edwin-key + (list extended-char (integer->char 68)) ;New key = F10 + (list meta-char (integer->char 62))) ;Old key = META > (buffer bottom) + +(remap-edwin-key + (list extended-char (integer->char 83)) ;New Key = DEL + (integer->char 04)) ;Old Key = CNTRL-D + +(remap-edwin-key + (list extended-char (integer->char 115)) ;New key = CNTRL <- + (list meta-char (integer->char 02))) ;Old key = META-CNTRL-B + ;Move forward over s-exp + +(remap-edwin-key + (list extended-char (integer->char 116)) ;New Key = CNTRL -> + (list meta-char (integer->char 06))) ;Old key = META-CNTRL-F + ;Move backward over s-exp + \ No newline at end of file diff --git a/newpcs/filepos.s b/newpcs/filepos.s new file mode 100644 index 0000000..469e581 --- /dev/null +++ b/newpcs/filepos.s @@ -0,0 +1,85 @@ +;**************************************************************************** +;* SET-FILE-POSITION will move the file pointer to a new position * +;* and update a pointer in the buffer to point to a new location. * +;* The offset variable can be: * +;* 0 for positioning from the start of the file * +;* 1 for positioning relative to the current position * +;* 2 for positioning from the end of the file * +;**************************************************************************** + +(define set-file-position! ; ==> filepos.s + (lambda (port #-of-bytes offset) + (let ((current-pos (%reify-port port 9)) + (end-of-buffer (%reify-port port 10)) + (new-pos '()) + (current-chunk (max 0 (-1+ (%reify-port port 12)))) + (new-chunk '()) + (messages '()) + (file-size (+ (* (%reify-port port 4) 65536) (%reify-port port 6))) + (port-flags (%reify-port port 11))) + (if (and (port? port) + (=? (%logand port-flags 4) 0)) + (case offset + ((0) ; offset from the start of the file + (set! #-of-bytes (abs #-of-bytes)) + (if (=? (%logand port-flags 3) 0) + (set! #-of-bytes (min #-of-bytes file-size))) + (set! new-chunk (truncate (/ #-of-bytes 256))) + (set! new-pos (- #-of-bytes (* new-chunk 256))) + (if (and (=? new-pos 0) + (=? (%logand port-flags 3) 0) ; open for reading + (=? new-chunk current-chunk)) + (%reify-port! port 9 new-pos) + (%sfpos port new-chunk new-pos))) + + ((1) ; offset from the current position + (set! new-pos (+ current-pos #-of-bytes)) + (if (and (=? new-pos 0) + (=? (%logand port-flags 3) 0)) ; open for reading + (%reify-port! port 9 new-pos) + (begin + (set! new-pos (+ (+ current-pos (* 256 current-chunk)) + #-of-bytes)) ; offset from the begining of the file + (if (and (>? new-pos file-size) + (=? (%logand port-flags 3) 0)) + (set! new-pos file-size)) + (if (=? new-pos 0) + (=? new-chunk current-chunk)) + (%reify-port! port 9 new-pos) + (%sfpos port new-chunk new-pos)) + (display "Offset from the end of the file can only be used with files open for reading!") + )) + (else (display "Offset must be 0, 1 or 2!"))) + (display "First parameter must be a file!"))))) + +;****************************************************************** +;* get-file-position will return the current file position in the * +;* number of bytes from the beginning of the file. * +;****************************************************************** + +(define get-file-position + (lambda (port) + (let (( result '()) + (chunk (max 1 (%reify-port port 12)))) + (if (and (port? port) + (=? (%logand (%reify-port port 11) 4) 0)) + (set! result (+ (* 256 (-1+ chunk)) ; chunk# + (%reify-port port 9))) ; current position + (set! result "Needs to be a port/file object!")) + result))) + + \ No newline at end of file diff --git a/newpcs/graphics.s b/newpcs/graphics.s new file mode 100644 index 0000000..e953ab0 --- /dev/null +++ b/newpcs/graphics.s @@ -0,0 +1,58 @@ +(define-integrable setp + (lambda (x y color xor) + (%graphics 1 x y color 0 0 xor))) +(define-integrable resetp + (lambda (cc nc) + (%graphics 2 cc nc 0 0 0 0))) +(define-integrable line + (lambda (x1 y1 x2 y2 color xor) + (%graphics 3 x1 y1 x2 y2 color xor))) +(define-integrable point + (lambda (x y) + (%graphics 4 x y 0 0 0 0))) +(define-integrable draw-box + (lambda (x1 y1 x2 y2 color xor) + (%graphics 6 x1 y1 x2 y2 color xor))) +(define-integrable draw-filled-box + (lambda (x1 y1 x2 y2 color xor) + (%graphics 7 x1 y1 x2 y2 color xor))) +(define-integrable clipping-rectangle + (lambda (x1 y1 x2 y2) + (%graphics 8 x1 y1 x2 y2 0 0))) +; +; x and y are coordinates of upper left corner of picture +; a and b are coordinates of upper left corner of clipping rectangle +; c and d are coordinates of lower right corner of clipping rectangle +; +(define cga-example + (lambda (x y a b c d) + ; set video mode to graphics + (set-video-mode! 4) + (ti-example x y a b c d) + (display "Type a key to return to mode 3") + (read-char 'console) + ; return to text mode + (set-video-mode! 3))) +(define ega-example + (lambda (x y a b c d) + ; set video mode to graphics + (set-video-mode! 16) + (ti-example x y a b c d))) +(define ti-example + (lambda (x y a b c d) + (clear-graphics) + ; set clipping rectangle + (clipping-rectangle a b c d) + ; draw box (replace) + (draw-box (+ x 10) (+ y 20) (+ x 50) (+ y 50) 3 0) + ; draw filled box (exclusive or) + (draw-filled-box (+ x 30) (+ y 30) (+ x 90) (+ y 120) 2 1) + ; draw line (exclusive or) + (line (+ x 10) (+ y 20) (+ x 90) (+ y 120) 1 1) + ; set point + (setp (+ x 20) (+ y 20) 2 0) + ; set palette + (resetp 2 6) + ; read color of point + (point (+ x 20) (+ y 20)))) + \ No newline at end of file diff --git a/newpcs/help.s b/newpcs/help.s new file mode 100644 index 0000000..e79dc44 --- /dev/null +++ b/newpcs/help.s @@ -0,0 +1,206 @@ +;;;; APPENDIX: HELP SYSTEM SOURCE CODE + +;;;; +;;;; A Help facility for PC Scheme +;;;; +;;;; Precis of instructions: +;;;; 1. Load this file, i.e., type (load "help.s") +;;;; 2. To extract information on the definitions +;;;; in a file of Scheme source code, type +;;;; (extract-help "filename"). +;;;; 3. To extract the help information and +;;;; at the same time load the file, type +;;;; (load-with-help "filename"). +;;;; 4. Type (help 'ident) for information on the +;;;; name ident. +;;;; 5. Type (help), without arguments, for a list +;;;; of all identifiers for which extended +;;;; help is available. + +(define help + (lambda subject + (if (null? subject) + (show-help-topics) + (fetch-help (car subject))) + *the-non-printing-object*)) + + +(define fetch-help + (lambda (item) + (report-help item + (get-internal-help item) + (get-archival-help item)))) + +(define get-internal-help + (lambda (item) + (let ((item-class (classify item))) + (if (and (symbol? item) (bound? item)) + (let* ((value (eval item)) + (value-class (classify value))) + (list item-class value value-class)) + (list item-class))))) + + +(define classify + (lambda (x) + (cond ((pair? x) 'pair) + ((procedure? x) (cond ((closure? x) 'procedure) + ((continuation? x) 'continuation) + (else 'engine))) + ((boolean? x) 'boolean) + ((symbol? x) 'symbol) + ((environment? x) 'environment) + ((stream? x) 'stream) + ((port? x) 'port) + ((number? x) 'number) + ((char? x) 'character) + ((string? x) 'string) + ((vector? x) 'vector) + (else 'unknown)))) + + +(define bound? + (lambda (ident) + (not (eval `(unbound? ,ident))))) + + +(define archive + (let ((a-list '() )) + (lambda (msg . args) + (case msg + ((get) (cadr (assq (car args) a-list))) + ((put) (archive 'remove (car args)) + (set! a-list (cons args a-list))) + ((keys) (map car a-list)) + ((remove) (set! a-list (delq! (assq (car args) a-list) a-list))) + (else (error "Unrecognized message to archive:" msg)))))) + + +(define get-archival-help + (lambda (item) + (archive 'get item))) + + +(define show-help-topics + (lambda () + (writeln "Topics for which extended help is available:") + (for-each writeln (archive 'keys)))) + + +(define extract-help + (lambda (filename) + (with-input-from-file filename + (lambda () + (do ((next (read) (read))) + ((eof-object? next) 'OK) + (let ((info (parse next))) + (when info (put-archival-help filename info)))))))) + + +(define parse + (lambda (expr) + (if (and (pair? expr) (eq? (car expr) 'define)) + (if (pair? (cadr expr)) + (parse-mit (cadr expr)) + (parse-iu (cdr expr))) + '() ))) + + +(define parse-mit + (lambda (expr) + (if (pair? (car expr)) + (parse-mit (car expr)) + (parse-params (car expr) (cdr expr))))) + + +(define parse-iu + (lambda (expr) + (let ((lambda-form (get-lambda (cadr expr)))) + (if lambda-form + (parse-params (car expr) (cadr lambda-form)) + '() )))) + + +(define get-lambda + (lambda (e) + (if (or (null? e) (atom? e)) + '() + (case (car e) + ((lambda) e) + ((let let* letrec) (get-lambda (car (last-pair e)))) + (else '() ))))) + + +(define parse-params + (lambda (name paramlist) + (let loop ((params paramlist) (count 0)) + (cond ((null? params) (list name count 0 paramlist)) + ((atom? params) (list name count 1 paramlist)) + (else (loop (cdr params) (+ 1 count))))))) + + +(define put-archival-help + (lambda (filename info) + (archive 'put (car info) (append (list filename) + (cdr info))))) + + +(define load-with-help + (lambda (filename) + (extract-help filename) + (load filename))) + + +(define report-help + (lambda (item internal-info archival-info) + (let ((item-class (car internal-info)) + (value (cadr internal-info)) + (value-class (caddr internal-info))) + (newline) + (cond ((not (symbol? item)) (report-literal item item-class)) + ((null? value-class) (report-unbound item)) + (else (report-binding item value value-class))) + (when archival-info (report-archival item archival-info))))) + + +(define report-literal + (lambda (item class) + (writeln item " is an object of type " class ".") + (newline))) + + +(define report-unbound + (lambda (item) + (writeln "The identifier " item " is unbound.") + (newline))) + + +(define report-binding + (lambda (item value class) + (writeln "The identifier " item + " is bound to an object of type " class ".") + (when (denotable? class) + (writeln "The value of " item " is " value ".")) + (newline))) +(define denotable? + (lambda (class) + (memq class '(boolean number character string vector pair symbol)))) + + +(define report-archival + (lambda (item info) + (let* ((filename (car info)) + (req-args (cadr info)) + (opt-args (caddr info)) + (params (cadddr info)) + (argstr (if (= 1 req-args) "argument" "arguments")) + (optstr (if (zero? opt-args) "no" "any number of"))) + (writeln item " is defined in file " filename) + (writeln "as a procedure of " req-args " required " argstr) + (writeln "and " optstr " optional arguments.") + (writeln "The parameters to " item " are declared as follows:") + (writeln params) + (newline)))) + + + \ No newline at end of file diff --git a/newpcs/kldscope.s b/newpcs/kldscope.s new file mode 100644 index 0000000..cad81cb --- /dev/null +++ b/newpcs/kldscope.s @@ -0,0 +1,150 @@ +;;; Sample graphics routines using the %GRAPHICS primitive. + +;;; Note that %GRAPHICS may change in meaning in future versions of the system, +;;; as it has between versions 2.0 and 3.0. +;;; Using macros or define-integrables to protect your code +;;; from explicit uses of %GRAPHICS is highly recommended. + +;;; Determine what type of video adapter we have. +(define video-type + (lambda () + (if (= pcs-machine-type 1) + ;; it's TI + 'ti + ;; it's IBM + (let ((mode (%graphics 5 0 0 0 0 0 0))) ;; get video mode + (case mode + (3 'cga) + ((14 16) 'ega) + (else 'cga)))))) + + +;;; Initialize Graphics (sets palette registers; clears graphics planes) +(define grinit + (lambda () + (case (video-type) + (ti (%graphics 0 0 0 0 0 0 0) ;; clear graphics + (window-clear (make-window "" '()))) + (cga (%graphics 0 4 0 0 0 0 0) ;; 4-color graphics mode + (%graphics 2 0 0 0 0 0 0) ;; set background to black + (%graphics 2 1 0 0 0 0 0)) ;; use black,red,green,brown + (ega (%graphics 0 16 0 0 0 0 0) ;; 16-color graphics mode + (%graphics 2 0 0 0 0 0 0) ;; not necessary here + (%graphics 2 1 0 0 0 0 0)) + ))) + + +; Set point +(define-integrable setp + (lambda (x y color) (%graphics 1 x y color 0 0 0))) + +; Reset point (turns it off) +(define-integrable resetp + (lambda (x y) (%graphics 2 x y 0 0 0 0))) + +; Draw Line +(define-integrable line + (lambda (x1 y1 x2 y2 color) + (%graphics 3 x1 y1 x2 y2 color 0))) + +; Read Point (returns its color) +(define-integrable point + (lambda (x y) (%graphics 4 x y 0 0 0 0))) + +; %graphics 5 is identical to get-video-mode + +; Draw box +(define-integrable draw-box + (lambda (x1 y1 x2 y2 color) + (%graphics 6 x1 y1 x2 y2 color 0))) + +; Draw Filled Box +(define-integrable draw-filled-box + (lambda (x1 y1 x2 y2 color) + (%graphics 7 x1 y1 x2 y2 color 0))) + + +; Kaleidoscope Program [Translated from Basic] + +; Note: To stop this program, press the "q" key. To start a new pattern +; going, press any other key. +(alias kldscope kald) +(alias kaleidosope kald) +(define kald + (lambda () + (let* ((old-video-mode (%graphics 5 0 0 0 0 0 0)) + (vmode (video-type)) + (accel-range (case vmode (ti 12) (cga 6) (ega 12))) + (accel-adj (case vmode (ti 5) (cga 3) (ega 5))) + (usable-colors (case vmode (ti 7) (cga 3) (ega 15))) + (wh (case vmode (ti 360) (cga 160) (ega 320))) + (mi (case vmode (ti 145) (cga 75) (ega 150))) + (ycenter-offset (case vmode (ti 5) (cga 25) (ega 25))) + ;; Add 5/25/25 (TI/CGA/EGA) to y-coordinates 'cause we said that the + ;; screens are only 290/150/300-pixels high when, in actuality, + ;; they're 300/200/350. + (m1 (+ mi 1)) + (xv1 nil) + (xv2 nil) + (yv1 nil) + (yv2 nil) + ) + (letrec + ( + (quit-kald + (lambda () + (grinit) + (%graphics 0 old-video-mode 0 0 0 0 0) + (window-set-cursor! 'console 0 0) + (gc) + *the-non-printing-object* + )) + (loop + (lambda (a n color x1 y1 x2 y2) + (cond ((positive? a) + (let ((2x1 (+ x1 x1)) + (2y1 (+ y1 y1)) + (2x2 (+ x2 x2)) + (2y2 (+ y2 y2)) + (w wh) + (m (+ mi ycenter-offset))) + (line (+ w 2x1) (- m y1) (+ w 2x2) (- m y2) color) ; 1 + (line (- w 2y1) (+ m x1) (- w 2y2) (+ m x2) color) ; 2 + (line (- w 2x1) (- m y1) (- w 2x2) (- m y2) color) ; 3 + (line (- w 2y1) (- m x1) (- w 2y2) (- m x2) color) ; 4 + (line (- w 2x1) (+ m y1) (- w 2x2) (+ m y2) color) ; 5 + (line (+ w 2y1) (- m x1) (+ w 2y2) (- m x2) color) ; 6 + (line (+ w 2x1) (+ m y1) (+ w 2x2) (+ m y2) color) ; 7 + (line (+ w 2y1) (+ m x1) (+ w 2y2) (+ m x2) color) ; 8 + (if (positive? n) + (loop (- a 1) + (- n 1) + color + (remainder (+ x1 xv1) m1) + (remainder (+ y1 yv1) m1) + (remainder (+ x2 xv2) m1) + (remainder (+ y2 yv2) m1)) + (restart)))) + ((not (char-ready?)) + (set! xv1 (- (random accel-range) accel-adj)) + (set! yv1 (- (random accel-range) accel-adj)) + (set! xv2 (- (random accel-range) accel-adj)) + (set! yv2 (- (random accel-range) accel-adj)) + (loop (random 10) n (+ (random usable-colors) 1) x1 y1 x2 y2)) + ((eq? (char-upcase (read-char)) '#\Q) + (quit-kald)) + (else + (restart))))) + (restart + (lambda () + (grinit) + (randomize 0) + (loop 0 (+ 50 (random 200)) 0 + (+ (random mi) 1) + (+ (random mi) 1) + (+ (random mi) 1) + (+ (random mi) 1))))) + (begin + (flush-input) + (restart)))))) + \ No newline at end of file diff --git a/newpcs/oldpmath.s b/newpcs/oldpmath.s new file mode 100644 index 0000000..deecfd1 --- /dev/null +++ b/newpcs/oldpmath.s @@ -0,0 +1,262 @@ + +; -*- Mode: Lisp -*- Filename: pmath.s + +; Last Revision: 12-Sep-85 1930ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; Clyde R. Camp, David Bartley, ; +; Mark Meyer, John Gateley ; +; ; +; Extended Arithmetic Routines ; +; ; +;--------------------------------------------------------------------------; + + +(define exact? ; EXACT? + (lambda (n) + #!false)) + +(define inexact? ; INEXACT? + (lambda (n) + #!true)) + +(begin + (define acos) + (define asin) + (define atan) + (define cos) + (define exp) + (define expt) + (define log) + (define sin) + (define sqrt) + (define tan) + (define pi) + ) + +(letrec + (( *pi* 3.141592653589793) ; pi + ( *pi/2* (/ *pi* 2)) ; pi/2 + ( *2pi* (+ *pi* *pi*)) ; 2pi + ( *e* 2.718281828459045) ; e + + (%bad-argument + (lambda (name arg) + (%error-invalid-operand name arg))) + + (signum + (lambda (x) + (cond ((negative? x) -1) + ((positive? x) 1) + (else 0)))) + + (power-loop + (lambda (x n a) ; A is initially 1, N is non-negative + (if (zero? n) + a + (power-loop (* x x) + (quotient n 2) + (if (odd? n) (* a x) a))))) + + (pcs-series + (lambda (x y z) + (if (null? y) + z + (pcs-series x (cdr y) (- 1.0 (* (/ x (car y)) z)))))) + + (fact-series + (lambda (x n result) + (if (zero? n) + result + (fact-series x (- n 1) (+ 1 (* (/ x n) result)))))) + ) + (begin + + (set! sqrt + (letrec ((loop (lambda (x gx) + (let ((ngx (* 0.5 (+ gx (/ x gx))))) + (if (>? (/ (abs (- ngx gx)) gx) 5e-15) + (loop x ngx) + ngx))))) + (named-lambda (sqrt x) + (if (or (not (number? x)) (negative? x)) + (%bad-argument 'SQRT x) + (let ((x (float x))) + (if (zero? x) + x + (cond ((>? x 1.0e10)(* 1.0e5 (sqrt (* x 1.0e-10)))) + ((? x *pi*) + (set! x (- x *2pi*))) + (if (>? x *pi/2*) + (set! x (- *pi* x)) + (when (=? n lim) (+ sum term)) + (set! term (- (/ (* term x2) + (* n (+ n 1)))))) )) + ; The following limits (sin x) to +/- 1 + ; without it result can be 1.0 + 1e-18 + ; which blows up ASIN + (cond ((>? ssum 1.0) 1.0) + ((? y 1.0) + (- *pi/2* (atan (/ 1.0 y)))) + (else + (/ y (+ 1 (loop (* y y) 1))))) + (let ((x (car z))) + (cond ((not (number? x)) + (%bad-argument 'ATAN x)) + ((zero? x) + (cond ((zero? y) + (%bad-argument 'ATAN + x)) + ((negative? y) + (minus *pi/2*)) + (else *pi/2*))) + ((zero? y) + (if (positive? x) 0.0 *pi*)) + ((positive? y) + (if (>? x 0) + (atan (/ y x)) + (- *pi/2* (atan (/ x y))))) + ((and (? (abs x) 1.0)) + (%bad-argument 'ACOS x) + (atan (sqrt (- 1.0 (* x x))) x)))) + + (set! pi *pi*) + + (set! asin + (lambda (x) + (if (or (not (number? x)) + (>? (abs x) 1.0)) + (%bad-argument 'ASIN x) + (atan x (sqrt (- 1.0 (* x x))))))) + + (set! log + (named-lambda (log x . base) + (letrec + ((ln (lambda (x) + (cond ((=? x 1) 0) + ((? x *e*) (1+ (ln (/ x *e*)))) + (else (let ((y (/ (-1+ x) (1+ x)))) + (* (pcs-series (* y y) + '(-1.0952380952381 + -1.10526315789474 + -1.11764705882353 + -1.33333333333333 + -1.15384615384615 + -1.18181818181818 + -1.22222222222222 + -1.28571428571429 + -1.4 + -1.66666666666667 + -3.0) + 1.0) + (+ y y)))) )))) + (if (or (not (number? x)) (<=? x 0)) + (%bad-argument 'LOG x) + (let ((lnx (ln x))) + (if (null? base) + lnx + (let ((non-e-base (car base))) + (if (or (not (number? non-e-base)) + (not (positive? non-e-base))) + (%bad-argument 'LOG non-e-base) + (/ lnx (log non-e-base)))))))))) + + (set! exp + (named-lambda (exp x) + (cond ((not (number? x)) + (%bad-argument 'EXP x)) + ((zero? x) 1.0) + ((negative? x) (/ (exp (- x)))) + ((integer? x) (power-loop *e* x 1)) + (else + (let* ((q (truncate x)) + (p (- x q))) + (* (power-loop *e* q 1) + (fact-series p 12 1))))))) + + (set! expt + (named-lambda (expt a x) + (cond ((not (number? a)) + (%bad-argument 'EXPT a)) + ((not (number? x)) + (%bad-argument 'EXPT x)) + ((and (zero? a) (zero? x) (not (integer? x))) + (%bad-argument 'EXPT x)) + ((zero? x) (if (integer? a) 1 1.0)) + ((negative? x) (/ (expt a (minus x)))) + ((integer? x) (power-loop a x 1)) + (else + (let* ((z (* x (log (abs a)))) + (q (truncate z)) + (p (- z q))) + (* (if (negative? q) + (/ (power-loop *e* (minus q) 1)) + (power-loop *e* q 1)) + (signum a) + (fact-series p 12 1))))) )) + )) + \ No newline at end of file diff --git a/newpcs/padvise.s b/newpcs/padvise.s new file mode 100644 index 0000000..315e27c --- /dev/null +++ b/newpcs/padvise.s @@ -0,0 +1,331 @@ + +; -*- Mode: Lisp -*- Filename: padvise.s + +; Last Revision: 1-Oct-85 1400ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; MIT Scheme Advisory Procedures ; +; ; +;--------------------------------------------------------------------------; + +(begin + (define *args*) + (define *proc*) + (define *result*) + (define advise-entry) + (define advise-exit) + (define break) + (define break-both) + (define break-entry) + (define break-exit) + (define trace) + (define trace-both) + (define trace-entry) + (define trace-exit) + (define unadvise) + (define unadvise-entry) + (define unadvise-exit) + (define unbreak) + (define unbreak-entry) + (define unbreak-exit) + (define untrace) + (define untrace-entry) + (define untrace-exit) + (define %advise-info-vector-list) + ) + +;;; info-vector format: +;;; +;;; 0 : LINK next info-vector / () ** NOT USED ** +;;; 1 : WRAPPER orig closure object with new contents +;;; 2 : WRAPPEE new closure object with old contents +;;; 3 : ENTRY-ADVICE list of entry procedures / () +;;; 4 : EXIT-ADVICE list of exit procedures / () +;;; +;;; closure object format: +;;; +;;; -1 : LENGTH (indices are for use with %REIFY) +;;; 0 : DEBUG-INFO source, name, etc +;;; 1 : ENVIRONMENT environment object +;;; 2 : CB displacement VM address +;;; 3 : CB offset to entry VM fixnum +;;; 4 : NARGS fixnum + + +(letrec + ( + (*args*value '()) ; *ARGS*VALUE + (*proc*value '()) ; *PROC*VALUE + (*result*value '()) ; *RESULT*VALUE + + (info-vector-list '()) ; INFO-VECTOR-LIST + + + (add-advice ; ADD-ADVICE + (lambda (proc advice index) + (if (and (closure? proc)(closure? advice)) + (let* ((info (get-info-vector proc info-vector-list)) + (advl (vector-ref info index))) + (when (not (memq advice advl)) + (vector-set! info index + (cons advice advl))) + 'OK) + (%error-invalid-operand-list 'ADVISE proc advice)))) + + + (get-info-vector ; GET-INFO-VECTOR + (lambda (wrappee iv-list) + (cond ((null? iv-list) + (let* ((info (make-vector 5 '())) + (wrapper (make-wrapper info))) + (set! info-vector-list + (cons info info-vector-list)) + (swap-closure-contents + wrapper wrappee 4) + (vector-set! info 1 ; 1=WRAPPER + wrappee) ; swap! + (vector-set! info 2 ; 2=WRAPPEE + wrapper) ; swap! + info)) + ((eq? wrappee + (vector-ref (car iv-list) 1)) ; 1=WRAPPER (not WRAPPEE) + (car iv-list)) + (else + (get-info-vector wrappee (cdr iv-list)))))) + + + (swap-closure-contents ; SWAP-CLOSURE-CONTENTS + (lambda (wrapper wrappee index) + (if (zero? index) + (%reify! wrapper index ; copy the debug info + (%reify wrappee index)) + (let ((value (%reify wrapper index))) + (%reify! wrapper index (%reify wrappee index)) + (%reify! wrappee index value) + (swap-closure-contents wrapper wrappee (- index 1)))))) + + + (rem-advice ; REM-ADVICE + (lambda (args ; (proc) -or- () ==> all + advice ; advice-proc -or- () ==> all + index) ; 3 -or- 4, entry/exit + (let ((proc (car args))) + (when (and proc (not (closure? proc))) + (apply %error-invalid-operand-list + (cons 'UNADVISE args))) + (remove-advice proc advice index + info-vector-list '()) + 'OK))) + + + (remove-advice ; REMOVE-ADVICE + (lambda (proc advice index iv-list new-iv-list) + (if (null? iv-list) + (set! info-vector-list new-iv-list) + (let ((info (car iv-list))) + (cond ((null? proc) + (vector-set! info index '())) + ((eq? proc (vector-ref info 1)) + (vector-set! info index + (if (null? advice) + '() + (delq! advice + (vector-ref info index)))))) + (if (or (vector-ref info 3) + (vector-ref info 4)) + (remove-advice proc advice index + (cdr iv-list) + (cons info new-iv-list)) + (begin + (swap-closure-contents + (vector-ref info 1) ; 1=WRAPPER + (vector-ref info 2) ; 2=WRAPPEE + 4) + (remove-advice proc advice index + (cdr iv-list) + new-iv-list))))))) + + + (make-wrapper ; MAKE-WRAPPER + (lambda (info-vector) + (lambda args + (call/cc + (fluid-lambda (%*BREAK*continuation) + (let* ((info info-vector) ; cache INFO-VECTOR + (proc (vector-ref info 2)) ; 2=WRAPPEE + (env (procedure-environment proc))) + (do ((advice (vector-ref info 3) ; 3=ENTRY-ADVICE + (cdr advice))) + ((null? advice)) + ((car advice) proc args env)) + (do ((result (apply proc args) + ((car advice) proc args result env)) + (advice (vector-ref info 4) ; 4=EXIT-ADVICE + (cdr advice))) + ((null? advice) + result)))))))) + + + (print-arg-list ; PRINT-ARG-LIST + (lambda (num args) + (newline) + (when args + (princ " Argument ") (princ num) (princ ": ") + (prin1 (car args)) + (print-arg-list (+ num 1) (cdr args))))) + + + (std-break-entry ; STD-BREAK-ENTRY + (lambda (proc args env) + (set! *proc*value proc) + (set! *args*value args) + (set! *result*value '()) + (breakpoint-procedure 'BREAK-ENTRY + (cons proc args) + env + (%reify-stack + (+ (%reify-stack + (+ (%reify-stack -1) 6)) 6))) + *args*value)) + + + (std-break-exit ; STD-BREAK-EXIT + (lambda (proc args result env) + (set! *proc*value proc) + (set! *args*value args) + (set! *result*value result) + (breakpoint-procedure 'BREAK-EXIT + (list (cons proc args) + '|-->| + result) + env + (%reify-stack + (+ (%reify-stack + (+ (%reify-stack -1) 6)) 6))) + *result*value)) + + + (std-trace-entry ; STD-TRACE-ENTRY + (lambda (proc args env) + (fresh-line) + (princ " >>> Entering ") + (prin1 proc) + (print-arg-list 1 args) + args)) + + + (std-trace-exit ; STD-TRACE-EXIT + (lambda (proc args result env) + (fresh-line) + (princ " <<< Leaving ") + (prin1 proc) + (princ " with value ") + (prin1 result) + (print-arg-list 1 args) + result)) + + ) ; -------------------------------------------------------------- + (begin + + (set! *args* ; *ARGS* + (lambda () *args*value)) + + (set! *proc* ; *PROC* + (lambda () *proc*value)) + + (set! *result* ; *RESULT* + (lambda () *result*value)) + + (set! advise-entry ; ADVISE-ENTRY + (lambda (proc advice) + (add-advice proc advice 3))) + + (set! advise-exit ; ADVISE-EXIT + (lambda (proc advice) + (add-advice proc advice 4))) + + (set! break ; BREAK + (lambda (proc) + (add-advice proc std-break-entry 3))) + + (set! break-both ; BREAK-BOTH + (lambda (proc) + (break-entry proc) + (break-exit proc))) + + (set! break-entry ; BREAK-ENTRY + (lambda (proc) + (add-advice proc std-break-entry 3))) + + (set! break-exit ; BREAK-EXIT + (lambda (proc) + (add-advice proc std-break-exit 4))) + + (set! trace ; TRACE + (lambda (proc) + (add-advice proc std-trace-entry 3))) + + (set! trace-both ; TRACE-BOTH + (lambda (proc) + (trace-entry proc) + (trace-exit proc))) + + (set! trace-entry ; TRACE-ENTRY + (lambda (proc) + (add-advice proc std-trace-entry 3))) + + (set! trace-exit ; TRACE-EXIT + (lambda (proc) + (add-advice proc std-trace-exit 4))) + + (set! unadvise ; UNADVISE + (lambda args + (rem-advice args '() 3) + (rem-advice args '() 4))) + + (set! unadvise-entry ; UNADVISE-ENTRY + (lambda args + (rem-advice args '() 3))) + + (set! unadvise-exit ; UNADVISE-EXIT + (lambda args + (rem-advice args '() 4))) + + (set! unbreak ; UNBREAK + (lambda args + (rem-advice args std-break-entry 3) + (rem-advice args std-break-exit 4))) + + (set! unbreak-entry ; UNBREAK-ENTRY + (lambda args + (rem-advice args std-break-entry 3))) + + (set! unbreak-exit ; UNBREAK-EXIT + (lambda args + (rem-advice args std-break-exit 4))) + + (set! untrace ; UNTRACE + (lambda args + (rem-advice args std-trace-entry 3) + (rem-advice args std-trace-exit 4))) + + (set! untrace-entry ; UNTRACE-ENTRY + (lambda args + (rem-advice args std-trace-entry 3))) + + (set! untrace-exit ; UNTRACE-EXIT + (lambda args + (rem-advice args std-trace-exit 4))) + + (set! %advise-info-vector-list ; for debugging ADVISE + (lambda () info-vector-list)) + + ) ; -------------------------------------------------------------- + ) + \ No newline at end of file diff --git a/newpcs/pasm.s b/newpcs/pasm.s new file mode 100644 index 0000000..e1c825e --- /dev/null +++ b/newpcs/pasm.s @@ -0,0 +1,441 @@ + +; -*- Mode: Lisp -*- Filename: pasm.s + +; Last Revision: 3-Sep-85 1600ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985, 1987 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; The PCS Assembler ; +; ; +; rb 3/16/87 - added assembling variable-length instructions ; +; (the XLI %xesc instruction is such) ; +; ; +;--------------------------------------------------------------------------; +; +; Input: +; +; AL is a list of assembly language instructions and labels. +; +; Output: +; +; The output is a list of the following components: +; +; (PCS-CODE-BLOCK num-constants +; len-code +; (constant ...) +; (code-byte ...)) +; +; NUM-CONSTANTS is the number of constants. +; +; The list of constants contains all constants and names of globals +; and fluids which are referenced by the code. They are indexed from +; 0 to 255 from left to right. +; +; The code is represented as a series of integers in the range +; -255 .. 255 of length LEN-CODE. +; +; +; Pass 1: +; +; determine the "worst case" size of each instruction +; +; assign tentative locations to labels based on "worst case" sizes +; +; Pass 2: +; +; identify instructions which can use short-form addressing +; +; assign "final" locations to labels +; +; Pass 3: +; +; extract constants from the instructions and collect them +; +; translate the instruction stream into an encoded byte stream +; +;-------------------------------------------------------------------------- + +(define pcs-assembler + (lambda (al) + (letrec + ( +;-----! + + (max-constants 255) ; constants are indexed 0..255 + (max-immediate 127) ; largest signed immediate value + (min-immediate -128) ; smallest signed immediate value + (max-delta-pc 127) ; maximum jump displacement (short form) + + (labels '()) ; ((label . locn) ...) + (constants '()) ; (constant ...) + (code '()) ; (codebyte ...) + (pc 0) ; current simulated program counter + + (p1 + (lambda (al) + (when al + (let ((x (car al))) + (if (or (atom? x) ; label? + (number? (car x))) + (set! labels (cons (cons x pc) labels)) + (set! pc (+ pc (span x pc)))) + (p1 (cdr al)))))) + + (p2 + (lambda (al) + (when al + (let ((x (car al))) + (if (or (atom? x) ; label? + (number? (car x))) + (let ((entry (assq x labels))) + (set-cdr! entry pc)) + (set! pc (+ pc (span x pc)))) + (p2 (cdr al)))))) + + (p3 + (lambda (al) + (when al + (let ((x (car al))) + (if (or (atom? x) ; label? + (number? (car x))) + (let ((entry (assq x labels))) + (when (not (=? pc (cdr entry))) + (writeln " *** ERROR in PCS-ASSEMBLER: " x) + (set! pc (cdr entry)))) + (asm x)) + (p3 (cdr al)))))) + + (span + (lambda (x old-pc) + (let ((op (car x))) + (case op + (LOAD (if (and (not (atom? (caddr x))) + (eq? (car (caddr x)) 'STACK) + (not (zero? (caddr (caddr x))))) + 4 3)) + (STORE (if (and (not (atom? (cadr x))) + (eq? (car (cadr x)) 'STACK) + (not (zero? (caddr (cadr x))))) + 4 3)) + (JUMP (let ((long (length x)) + (entry (assoc (cadr x) labels))) + (if (null? entry) + long + (let* ((new-pc (+ old-pc long)) + (delta (- (cdr entry) new-pc))) + (if (<=? (abs delta) max-delta-pc) + (begin + (set-car! x 'HOP) ; short jump + (sub1 long)) + long))))) + (HOP (length (cdr x))) + (CALL (let ((kind (cadr x))) + (cond ((not (atom? kind)) 5) + ((eq? kind 'EXIT) 1) + ((eq? (caddr x) 'CC) 2) + (else 3)))) + (cons 4) + (CLOSE 5) + (LIVE 0) + (%XESC (let ((length (cadr (caddr x)))) + (add1 length))) + (else + (cond ((memq op '(PUSH POP DROP DROP-ENV PUSH-ENV UNBIND-FLUIDS)) + 2) + ((memq op '(car cdr caar cadr cdar cddr caaar caadr + cadar caddr cdaar cdadr cddar cdddr cadddr + %%car %%cdr BIND-FLUID)) + 3) + (else + (if (null? (cddr x)) ; no source operands + (if (getprop op 'pcs*nilargop) + 1 ; no source or dest + 2) ; dest only + (length (cdr x))))) + ))))) + + (asm + (lambda (x) + (let ((op (car x))) + (case op + (LOAD (asm-load (reg (cadr x)) (caddr x))) + (STORE (asm-store (cadr x) (reg (caddr x)))) + (JUMP (asm-jump x)) + (HOP (asm-hop x)) + (CALL (asm-call x)) + (cons (emit4 op (reg (cadr x)) (reg (caddr x)) (reg (cadddr x)))) + (POP (emit2 op (reg (cadr x)))) + (PUSH (emit2 op (reg (caddr x)))) + (DROP (emit2 op (car (cadr x)))) + (DROP-ENV + (emit2 op (car (cadr x)))) + (PUSH-ENV + (emit2 op (const (cadr x)))) + (UNBIND-FLUIDS + (emit2 op (length (cadr x)))) + (BIND-FLUID + (emit3 op (const (cadr x)) (reg (caddr x)))) + (%XESC ;format: (%xesc dest (quote len) r1 r2 ...) + ;discard redundant 'dest' in (cadr x) + (emitv-regs op (cadr (caddr x)) (cdddr x))) + (CLOSE (let* ((label (car (cadddr x))) + (target (cdr (assoc label labels))) + (delta (- target (+ pc 5))) + (dest (reg (cadr x))) + (nargs (cadr (cadddr x)))) + (emit5 op dest (lo-byte delta) (hi-byte delta) nargs))) + (LIVE '()) + (else + (cond ((memq op '(%%car %%cdr car cdr caar cadr cdar + cddr caaar caadr cadar caddr cdaar + cdadr cddar cdddr cadddr)) + (emit3 op (reg (cadr x)) (reg (caddr x)))) + ((memq op '(%+imm %*imm %/imm)) + (emit3 op (reg (caddr x)) (cadr (cadddr x)))) + (t (emit1 op) + (if (null? (cddr x)) ; no source operands + (if (getprop op 'pcs*nilargop) + '() ; no source or dest + (emit-regs (cdr x))) ; dest only + (emit-regs (cddr x))))) ; discard redundant 'dest' + ))))) + + (asm-load + (lambda (reg-dest src) + (if (number? src) + (emit3 'LOAD reg-dest (reg src)) + (case (car src) + (quote (let ((exp (cadr src))) + (if (and (integer? exp) + (<=? exp max-immediate) + (>=? exp min-immediate)) + (emit3 'LOAD-IMMEDIATE + reg-dest + exp) + (emit3 'LOAD-CONSTANT + reg-dest + (const exp))))) + (STACK (let ((offset (cadr src)) + (delta-level (caddr src))) + (if (zero? delta-level) + (emit3 'LOAD-LOCAL + reg-dest + offset) + (emit4 'LOAD-LEX + reg-dest + offset + delta-level)))) + (HEAP (emit3 'LOAD-ENV + reg-dest + (const (cadr src)))) + (GLOBAL (emit3 'LOAD-GLOBAL + reg-dest + (const (cadr src)))) + (FLUID (emit3 'LOAD-FLUID + reg-dest + (const (cadr src)))))))) + + (asm-store + (lambda (dest reg-src) + (case (car dest) + (STACK (let ((offset (cadr dest)) + (delta-level (caddr dest))) + (if (zero? delta-level) + (emit3 'STORE-LOCAL + reg-src + offset) + (emit4 'STORE-LEX + reg-src + offset + delta-level)))) + (HEAP (emit3 'STORE-ENV + reg-src + (const (cadr dest)))) + (GLOBAL (emit3 'STORE-GLOBAL + reg-src + (const (cadr dest)))) + (GLOBAL-DEF + (emit3 'STORE-GLOBAL-DEF + reg-src + (const (cadr dest)))) + (FLUID (emit3 'STORE-FLUID + reg-src + (const (cadr dest))))))) + + (asm-jump + (lambda (x) + (let* ((target (cdr (assoc (cadr x) labels))) + (len (length x)) + (delta (- target (+ pc len))) + (regs (cdddr x))) + (emit1 + (cdr (assq (caddr x) + '((ALWAYS . J_L) (NULL? . JN_L) (T? . JNN_L) + (ATOM? . JA_L) (NATOM? . JNA_L)(EQ? . JE_L) + (NEQ? . JNE_L))))) + (emit-regs regs) + (emit-byte (lo-byte delta)) + (emit-byte (hi-byte delta)) + ))) + + (asm-hop + (lambda (x) + (let* ((target (cdr (assoc (cadr x) labels))) + (len (length (cdr x))) + (delta (- target (+ pc len))) + (regs (cdddr x))) + (emit1 + (cdr (assq (caddr x) + '((ALWAYS . J_S) (NULL? . JN_S) (T? . JNN_S) + (ATOM? . JA_S) (NATOM? . JNA_S)(EQ? . JE_S) + (NEQ? . JNE_S))))) + (emit-regs regs) + (emit-byte delta) + ))) + + (asm-call + (lambda (x) + (let ((kind (cadr x))) + (cond ((not (atom? kind)) + (let* ((target (cdr (assoc (cadr kind) labels))) + (delta-level (caddr kind)) + (delta-heap (cadddr kind)) + (delta (- target (+ pc 5)))) + (emit5 (cdr (assq (car kind) + (if (and (cddr x)(eq? (caddr x) 'CC)) + '((OPEN . CCC) (OPEN-TR . CCC-TR)) + '((OPEN . CALL)(OPEN-TR . CALL-TR))))) + (lo-byte delta) (hi-byte delta) + delta-level delta-heap)) + ) + (else + (case kind + (EXIT (emit1 kind)) + (CLOSED (let ((fun-reg (reg (cadddr x)))) + (if (eq? (caddr x) 'CC) + (emit2 'CCC-CLOSED fun-reg) + (emit3 'CALL-CLOSURE + fun-reg + (car (caddr x)))))) ; nargs + (CLOSED-TR (let ((fun-reg (reg (cadddr x)))) + (if (eq? (caddr x) 'CC) + (emit2 'CCC-CLOSED-TR fun-reg) + (emit3 'CALL-CLOSURE-TR + fun-reg + (car (caddr x)))))) ; nargs + (CLOSED-APPLY + (emit3 'APPLY-CLOSURE + (reg (caddr x)) ; funreg + (reg (cadddr x)))) ; argreg + (CLOSED-APPLY-TR + (emit3 'APPLY-CLOSURE-TR + (reg (caddr x)) ; funreg + (reg (cadddr x)))) ; argreg + )))))) + + (const + (lambda (exp) + (let ((entry (memv exp constants))) + (length (cdr (or entry + (begin + (set! constants (cons exp constants)) + (if (>? (length constants) max-constants) + (error "Constants table overflow in compiler") + constants)))))))) + + (reg + (lambda (index) + (* 4 index))) + + (hi-byte + (lambda (n) + (let ((hi (quotient (abs n) 256))) + (if (negative? n) + (if (zero? (remainder (abs n) 256)) + (- 256 hi) + (- 255 hi)) + hi)))) + + (lo-byte + (lambda (n) + (let ((lo (remainder (abs n) 256))) + (if (negative? n) + (if (zero? lo) + lo + (- 256 lo)) + lo)))) + + (emit-byte + (lambda (byte) + (set! code (cons byte code)) + (set! pc (add1 pc)))) + + (emit-regs + (lambda (x) + (when x + (set! code (cons (reg (car x)) code)) + (set! pc (add1 pc)) + (emit-regs (cdr x))))) + + (emit-count + (lambda (len) + (set! code (cons len code)) + (set! pc (add1 pc)))) + + (emit1 + (lambda (op) + (let ((opcode (if pcs-binary-output + (abs (or (getprop op 'pcs*opcode) + (error "++ undefined opcode" op))) + op))) + (set! code (cons opcode code)) + (set! pc (+ pc 1))))) + + (emit2 + (lambda (op a) + (emit1 op) + (set! code (cons a code)) + (set! pc (+ pc 1)))) + + (emit3 + (lambda (op a b) + (emit1 op) + (set! code (cons b (cons a code))) + (set! pc (+ pc 2)))) + + (emit4 + (lambda (op a b c) + (emit1 op) + (set! code (cons c (cons b (cons a code)))) + (set! pc (+ pc 3)))) + + (emit5 + (lambda (op a b c d) + (emit1 op) + (set! code (cons d (cons c (cons b (cons a code))))) + (set! pc (+ pc 4)))) + + (emitv-regs + (lambda (op len l) + (emit1 op) + (emit-count len) + (emit-regs l))) + +;-----! + ) + (begin ;; body of pcs-assembler + (p1 al) + (when labels + (set! pc 0) + (p2 al)) + (set! pc 0) + (p3 al) + (set! constants (reverse! constants)) + (list 'PCS-CODE-BLOCK (length constants) pc + constants (reverse! code)))))) + \ No newline at end of file diff --git a/newpcs/pauto_c.s b/newpcs/pauto_c.s new file mode 100644 index 0000000..c6fc3ba --- /dev/null +++ b/newpcs/pauto_c.s @@ -0,0 +1,46 @@ +; -*- Mode: Lisp -*- Filename: compauto.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; Terry Caudill ; +; ; +; Autoload definitions for COMPILER.APP ; +; ; +;--------------------------------------------------------------------------; + +; Revision history: +; 6/02/87 tc - Removed from PSTL.S so that compiler and runtime versions +; can more easily be built. + +;;; +;;; Set up the standard autoload files. RUNAUTO.S also has autoload +;;; definitions for runtime version. Both COMPAUTO.S and RUNAUTO.S +;;; should be included in COMPILER.APP. + +(autoload-from-file (%system-file-name "SCOOPS.FSL") ; SCOOPS + '(load-scoops) + user-global-environment) + +(autoload-from-file (%system-file-name "PINSPECT.FSL") ; INSPECTOR + '(%inspect %inspector) + user-global-environment) + +(autoload-from-file (%system-file-name "PDEFSTR.FSL") ; DEFINE-STRUCTURE + '(%define-structure %make-structure %structure-predicate) + user-global-environment) + +(autoload-from-file (%system-file-name "EDIT.FSL") ; STRUCTURE EDITOR + '(edit) + user-global-environment) + +(autoload-from-file (%system-file-name "PADVISE.FSL") ; PADVISE + '(advise-entry advise-exit break break-both break-entry break-exit + trace trace-both trace-entry trace-exit unadvise unadvise-entry + unadvise-exit unbreak unbreak-entry unbreak-exit untrace untrace-entry + untrace-exit *args* *proc* *result*) + user-global-environment) + + \ No newline at end of file diff --git a/newpcs/pauto_r.s b/newpcs/pauto_r.s new file mode 100644 index 0000000..281eb41 --- /dev/null +++ b/newpcs/pauto_r.s @@ -0,0 +1,70 @@ +; -*- Mode: Lisp -*- Filename: runauto.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; Terry Caudill ; +; ; +; Autoload definitions for Runtime version ; +; ; +;--------------------------------------------------------------------------; + +; Revision history: +; 6/02/87 tc - Removed from PSTL.S so that runtime version can more +; easily be built. + +;;; +;;; Set up the standard autoload files. COMPAUTO.S also has autoload +;;; definitions for compiler version. Both COMPAUTO.S and RUNAUTO.S +;;; should be included in COMPILER.APP. + +(autoload-from-file (%system-file-name "PWINDOWS.FSL") ; windows + '(make-window window-clear window-delete + window-get-position window-set-position! + window-get-size window-set-size! window-get-cursor + window-set-cursor! window-popup window-popup-delete + window-get-attribute window-set-attribute!) + user-global-environment) + +(autoload-from-file (%system-file-name "PMATH.FSL") ; real arithmetic + '(acos asin atan cos exact? exp expt inexact? + log pi sin sqrt tan) + user-global-environment) + +(autoload-from-file (%system-file-name "PP.FSL") ; pretty printer + '(pp %pretty-printer %pp-me) + user-global-environment) + +(autoload-from-file (%system-file-name "PDOS.FSL") ; DOS facilities + '(dos-dir dos-call sw-int dos-delete dos-file-copy + dos-rename dos-file-size dos-chdir + dos-change-drive) + user-global-environment) + +(autoload-from-file (%system-file-name "PSORT.FSL") ; Sort package + '(sort! %sort-less?) + user-global-environment) + +(autoload-from-file (%system-file-name "PNUM2S.FSL") ; Number->String + '(number->string integer->string string->number) + user-global-environment) + +(autoload-from-file (%system-file-name "PFUNARG.FSL") + '(* + - / append append! char-ready? display list list* make-vector + make-string max min newline prin1 princ print read-line read-atom read-char + vector write write-char %xesc) + user-global-environment) + +(autoload-from-file (%system-file-name "PGR.FSL") + '(clear-graphics draw-point clear-point is-point-on? position-pen + draw-line-to set-pen-color! *graphics-colors* + set-video-mode! get-video-mode set-palette! + draw-box-to draw-filled-box-to + get-pen-color get-pen-position point-color set-clipping-rectangle! + ;; the following are experimental in PCS 3.0 + graphics-window current-graphics-window *character-boxes*) + user-global-environment) + + \ No newline at end of file diff --git a/newpcs/pboot.s b/newpcs/pboot.s new file mode 100644 index 0000000..af8fea7 --- /dev/null +++ b/newpcs/pboot.s @@ -0,0 +1,409 @@ + +; -*- Mode: Lisp -*- Filename: pboot.s + +; Last Revision: 3-Sep-85 1500ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Bootstrap Driver ; +; ; +; ; +; This routine contains compiler-specific code which should be used ; +; when compiling the compiler itself. It is generally loaded by the ; +; file "COMPILE.ALL" which handles compilation of the compiler and ; +; runtime routines. ; +; ; +; The file contains compiler-type definitions and macro definitions ; +; which must be included when compiling the compiler files. ; +; ; +;--------------------------------------------------------------------------; + +(begin + ; + ; Define aliases for the major parts of the compiler + ; + (alias pme pcs-macro-expand) + (alias psimp pcs-simplify) + (alias pca pcs-closure-analysis) + (alias pmr pcs-make-readable) + (alias pcg pcs-gencode) + (alias ppeep pcs-postgen) + (alias pal pcs-princode) + (alias pasm pcs-assembler) + + ; + ; Initialize compile-time variable definitions + ; + (set! pcs-local-var-count 0) + (set! pcs-verbose-flag #!true) + (set! pcs-permit-peep-1 #!true) + (set! pcs-permit-peep-2 #!true) + (set! pcs-error-flag #!false) + (set! pcs-binary-output #!false) + + ; + ; Set up variables to hold compiler-intermediate data and timing info + ; + (define pme= '()) + (define psimp= '()) + (define pca= '()) + (define pcg= '()) + (define ppeep= '()) + (define pasm= '()) + (define problem) + (define t-0) + (define t-pme) + (define t-psimp) + (define t-pca) + (define t-pcg) + (define t-ppeep) + (define t-pasm) + ) + +;;; -------------------------------------------------------------------- +;;; +;;; "Type definitions" +;;; +;;; The following macros are used by the compiler itself and must +;;; be defined when compiling the compiler. By keeping them here, +;;; the macro definitions will not be around in the object files +;;; of the compiler +;;; +;;; -------------------------------------------------------------------- + +(macro pcs-make-id ; PCS-MAKE-ID + (lambda (form) + (let ((name (cadr form))) + `(begin + (set! pcs-local-var-count (+ pcs-local-var-count 1)) + (list 'T ; the symbol T, not #!TRUE !! + (cons ,name + pcs-local-var-count) + '() '() '()))))) + + +;;; ---- (t (original-name . unique-number) +;;; funargsees? freeref? set!? . init) ---- + +(begin + (syntax (id-name id) (caadr id)) + (syntax (id-number id) (cdadr id)) + (syntax (id-funargsees? id) (car (cddr id))) + (syntax (id-freeref? id) (car (cdddr id))) + (syntax (id-set!? id) (cadr (cdddr id))) + (syntax (id-init id) (cddr (cdddr id))) + + (syntax (id-rtv? id) + (or (id-set!? id) + (null? (id-init id)) + (lambda-closed? (id-init id)))) + + (syntax (id-heap? id) + (and (id-funargsees? id) + (id-freeref? id) + (id-rtv? id))) + + (syntax (set-id-funargsees? id val) (set-car! (cddr id) val)) + (syntax (set-id-freeref? id val) (set-car! (cdddr id) val)) + (syntax (set-id-set!? id val) (set-car! (cdr (cdddr id)) val)) + (syntax (set-id-init id val) (set-cdr! (cdr (cdddr id)) val)) + ) + +;;; ------ (lambda bvl body . (nargs label . closed)) ------ + +(begin + (syntax (lambda-bvl x) (car (cdr x))) + (syntax (lambda-body x) (car (cddr x))) + (syntax (lambda-body-list x) (cddr x)) + (syntax (lambda-nargs x) (car (cdddr x))) + (syntax (lambda-label x) (car (cdr (cdddr x)))) + (syntax (lambda-debug x) (car (cddr (cdddr x)))) + (syntax (lambda-closed? x) (car (cdddr (cdddr x)))) + + (syntax (set-lambda-body x val) (set-car! (cddr x) val)) + (syntax (set-lambda-nargs x val) (set-car! (cdddr x) val)) + (syntax (set-lambda-label x val) (set-car! (cdr (cdddr x)) val)) + (syntax (set-lambda-debug x val) (set-car! (cddr (cdddr x)) val)) + (syntax (set-lambda-closed? x val) (set-car! (cdddr (cdddr x)) val)) + + (macro pcs-extend-lambda + (lambda (form) + `(let ((x ,(cadr form))) + (set-cdr! (cdddr x) ; X = ('lambda bvl body nargs) + (list '() ; label + '() ; debug info + '())) ; closed? + x))) + ) + +;;; ------ (letrec pairs body) ------ + +(begin + (syntax (letrec-pairs x) (car (cdr x))) + (syntax (letrec-body x) (car (cddr x))) + (syntax (letrec-body-list x) (cddr x)) + + (syntax (set-letrec-body x val) (set-car! (cddr x) val)) + ) + +;;; ------ (if pred then else) ------ + +(begin + (syntax (if-pred x) (car (cdr x))) + (syntax (if-then x) (car (cddr x))) + (syntax (if-else x) (car (cdddr x))) + + (syntax (set-if-pred x val) (set-car! (cdr x) val)) + (syntax (set-if-then x val) (set-car! (cddr x) val)) + (syntax (set-if-else x val) (set-car! (cdddr x) val)) + ) + +;;; ------ (set! id exp) ------ + +(begin + (syntax (set!-id x) (car (cdr x))) + (syntax (set!-exp x) (car (cddr x))) + + (syntax (set-set!-id x val) (set-car! (cdr x) val)) + (syntax (set-set!-exp x val) (set-car! (cddr x) val)) + ) + +;;; -------------------------------------------------------------------- + +(define pcs-make-readable ; PCS-MAKE-READABLE + (lambda (x) + (letrec +;-------! + ((pmr-exp + (lambda (x) + (if (atom? x) + x + (case (car x) + (quote x) + (t (pmr-id x)) + (lambda (pmr-lambda x)) + (letrec (pmr-letrec x)) + (else (mapcar pmr-exp x)))))) + + (pmr-id + (lambda (x)(cadr x))) + + (pmr-full-id + (lambda (x) + `(t (,(id-name x) . ,(id-number x)) + (funargsees?= ,(id-funargsees? x)) + (freeref?= ,(id-freeref? x)) + (set!?= ,(id-set!? x)) + (init= ,(if (id-init x) 'lambda '()))))) + + (pmr-lambda + (lambda (x) + `(lambda + ,(mapcar pmr-full-id (lambda-bvl x)) + ,(pmr-exp (lambda-body x)) + (label= ,(lambda-label x)) + (closed?= ,(lambda-closed? x))))) + + (pmr-letrec + (lambda (x) + `(letrec + ,(pmr-pairs (letrec-pairs x) '()) + ,(pmr-exp (letrec-body x))))) + + (pmr-pairs + (lambda (old new) + (if (null? old) + (reverse! new) + (pmr-pairs (cdr old) + (cons (list (pmr-full-id (caar old)) + (pmr-exp (cadar old))) + new))))) + + ) + (pmr-exp x)))) + +;;; -------------------------------------------------------------------- + +; +; filename-manipulating functions +; +(define filename-sans-extension + (lambda (file) + (let ((period (substring-find-next-char-in-set + file 0 (string-length file) "."))) + (if period + (substring file 0 period) + file)))) + +(define extension-sans-filename + (lambda (file) + (let ((period (substring-find-next-char-in-set + file 0 (string-length file) "."))) + (if period + (substring file period (string-length file)) + "")))) + +;;; -------------------------------------------------------------------- + +; +; Routine to compile a form, setting timing info and intermediate (between +; compiler phases) data. +; +(define pcs + (lambda (exp) + (begin + (set! pme= '()) + (set! psimp= '()) + (set! pca= '()) + (set! pcg= '()) + (set! pasm= '()) + (set! pcs-local-var-count 0) + (set! problem exp) + (set! pcs-error-flag #!false) + (set! t-0 (car (ptime))) + (set! pme= (pme exp )) + (set! t-pme (car (ptime))) + (if pcs-error-flag + (error "[Compilation terminated because of errors]") + (begin + (set! psimp= (psimp pme=)) + (set! t-psimp (car (ptime))) + (pca psimp=) + (set! t-pca (car (ptime))) + (set! pcg= (pcg psimp=)) + (set! t-pcg (car (ptime))) + (set! ppeep= (ppeep pcg=)) + (set! t-ppeep (car (ptime))) + (set! pasm= (pasm ppeep=)) + (set! t-pasm (car (ptime))) + )) + `(Times- Total= ,(- t-pasm t-0) + pme= ,(- t-pme t-0) + psimp= ,(- t-psimp t-pme) + pca= ,(- t-pca t-psimp) + pcg= ,(- t-pcg t-pca) + ppeep= ,(- t-ppeep t-pcg) + pasm= ,(- t-pasm t-ppeep)) + ))) + +; +; Compiles a given expression without executing the result +; +(define pcs-compile + (lambda (exp) + (set! pcs-verbose-flag #!false) + (set! pcs-binary-output #!true) + (set! pcs-local-var-count 0) + (set! pcs-error-flag #!false) + (let ((t1 (pme exp))) + (if pcs-error-flag + (error "[Compilation terminated because of errors.]") + (let ((t2 (psimp t1))) + (pca t2) + (pasm (ppeep (pcg t2)))))))) + + +; +; Set up compile-time aliases. When encountered in a source file, +; anything assigned via compile-time-alias will be defined as +; an alias, but will not be written to the object file. +; See pcs-compile-file in this file !!! +; +(alias compile-time-alias alias) + + +; +; Compiles a given file without executing (unless form is a macro, alias, +; syntax, or define-integrable) the result. Also report compilation info. +; +(define pcs-compile-file + (lambda (filename1 filename2) + (if (or (not (string? filename1)) + (not (string? filename2)) + (equal? filename1 filename2)) + (error "PCS-COMPILE-FILE arguments must be distinct file names" + filename1 + filename2) + (fluid-let ((input-port (open-input-file filename1))) + (let ((o-port (open-output-file filename2))) + (letrec + ((loop + (lambda (form) + (if (eof-object? form) + (begin (close-input-port (fluid input-port)) + (close-output-port o-port) + 'ok) + (begin (compile-to-file form) + (set! form '()) ; for GC + (loop (read)))))) + (compile-to-file + (lambda (form) + (let* ((cform (pcs-compile form)) + (nconstants (cadr cform)) + (nbytes (caddr cform)) + (name?? (car (cadddr cform)))) + (if (pair? form) + (if (eq? (car form) 'COMPILE-TIME-ALIAS) + (%execute cform) + ;else + (begin + (when (and (pair? form) + (memq (car form) + '(MACRO SYNTAX ALIAS + DEFINE-INTEGRABLE))) + (%execute cform)) + (writeln " " name?? ": (" + nconstants "," nbytes ")") + (fluid-let ((output-port o-port)) + (set-line-length! 74) ; was 120 !! + (prin1 `(%execute (quote ,cform))) + (newline))))))))) + (loop (read)))))))) +; +; Compile object code to file. The code generated by ppeep (the peephole +; optimizer is written to the specified file. +; +; +(define %compile-file + (lambda (filename1 filename2) + (if (or (not (string? filename1)) + (not (string? filename2)) + (equal? filename1 filename2)) + (error "%COMPILE-FILE arguments must be distinct file names" + filename1 + filename2) + (fluid-let ((input-port (open-input-file filename1))) + (let ((o-port (open-output-file filename2))) + (letrec + ((loop + (lambda (form) + (if (eof-object? form) + (begin (close-input-port (fluid input-port)) + (close-output-port o-port) + 'ok) + (begin (compile-to-file form) + (set! form '()) ; for GC + (loop (read)))))) + (compile-to-file + (lambda (form) + (let ((t1 (pme form))) + (if pcs-error-flag + (writeln "[Compilation terminated because of errors.]") + (let ((t2 (psimp t1))) + (pca t2) + (set! ppeep= (ppeep (pcg t2)))))) + (fluid-let ((output-port o-port)) + (set-line-length! 74) ; was 120 !! + (newline) + (pp form) + (newline) + (pcs-princode ppeep=) + (newline))))) + (loop (read)))))))) + + \ No newline at end of file diff --git a/newpcs/pca.s b/newpcs/pca.s new file mode 100644 index 0000000..f4708b6 --- /dev/null +++ b/newpcs/pca.s @@ -0,0 +1,271 @@ + +; -*- Mode: Lisp -*- Filename: pca.s + +; Last Revision: 1-Oct-85 1700ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Closure Analysis and Heap Allocation ; +; ; +;--------------------------------------------------------------------------; +; +; Pass 1 +; +; Mark lambda expressions to be closed (LAMBDA-CLOSED?=T) at the point +; of definition whenever any of the following occur: +; +; -- the identifier bound to the lambda expression is used as a +; funarg [p1-id] +; +; -- the lambda expression is itself used as a funarg +; [p1-lambda] +; +; -- the identifier bound to the lambda expression is modified +; by SET! [p1-set!] +; +; -- the expression is a MULAMBDA [p1-lambda] +; +; Mark all identifiers which are bound to closures by LETREC: +; +; -- ID-INIT: the lambda expression the ID was bound to +; (else it is NIL) [p1-lambda] +; +; Pass 2 +; +; Determine which variables must be heap-allocated by gathering the +; following facts used later: +; +; -- ID-SET!?: it is modified by a SET! [p2-set!] +; +; -- ID-FREEREF?: it is freely referenced by some function +; +; -- ID-FUNARGSEES?: it is "visible" to a closed function +; +; We do not compute the transitive closure of functions reachable from +; closed functions. Instead, we consider an ID to be funargref'd if +; (1) ID is freely referenced from SOME function AND (2) ID is visible, +; though not necessarily referenced, from a closed function. +; +; An ID will be heap-allocated if it is potentially referenced from a +; funarg (both ID-FREEREF? and ID-FUNARGSEES? set non-nil) and must +; exist at runtime. It exists at runtime if it is modified (ID-SET!?), +; or is initialized to some value other than a lambda expression +; (ID-INIT=NIL), or the lambda expression it is bound to is closed. +; +;--------------------------------------------------------------------------; + + +(define pcs-closure-analysis + (lambda (exp) + (letrec +;----! + ( + (p1-exp + (lambda (x) + (case (car x) + (quote '()) + (T (p1-id x)) + (lambda (p1-lambda x)) + (set! (p1-set! x)) + ;; (if (p1-args (cdr x))) treat as a primop + ;; (begin (p1-args (cdr x))) treat as a primop + (letrec (p1-letrec x)) + (else (p1-application x)) + ))) + + (p1-id + (lambda (id) + (close-funarg (id-init id)))) + + (p1-set! + (lambda (x) + (p1-id (set!-id x)) + (p1-exp (set!-exp x)))) + + (p1-lambda + (lambda (x) + (create-lambda-label x '()) + (close-funarg x) + (p1-exp (lambda-body x)))) + + (p1-letrec + (lambda (x) + (let ((pairs (letrec-pairs x))) + (p1-pairs-1 pairs) ; link up lambda's and id's + (p1-pairs-2 pairs) ; find funargref's to id's + (p1-exp (letrec-body x))))) + + (p1-pairs-1 + (lambda (pairs) + (when pairs + (let* ((pr (car pairs)) + (id (car pr)) + (exp (cadr pr))) + (when (eq? (car exp) 'lambda) + (create-lambda-label exp id) + (set-id-init id exp) + (when (negative? (lambda-nargs exp)) + (close-funarg exp))) + (p1-pairs-1 (cdr pairs)))))) + + (p1-pairs-2 + (lambda (pairs) + (when pairs + (let* ((pr (car pairs)) + (id (car pr)) + (exp (cadr pr))) + (if (eq? (car exp) 'lambda) + (p1-exp (lambda-body exp)) + (p1-exp exp)) + (p1-pairs-2 (cdr pairs)))))) + + (p1-application + (lambda (x) + (let ((fn (car x)) + (args (cdr x))) + (p1-args args) + (cond ((or (atom? fn) + (eq? (car fn) 'T)) + '()) + ((eq? (car fn) 'LAMBDA) + (p1-exp (lambda-body fn))) + (else + (p1-exp fn)))))) + + (p1-args + (lambda (args) + (when args + (p1-exp (car args)) + (p1-args (cdr args))))) + + (close-funarg + (lambda (fn) + (when fn + (set-lambda-closed? fn #!true)))) + + (create-lambda-label + (lambda (fn id) + (set-lambda-label fn + (if (null? id) + (pcs-make-label 'lambda) + (cons (id-number id)(id-name id)))))) + + ;; ------ pass 2 ------- + + (p2-exp + (lambda (x env locals) + (case (car x) + (quote '()) + (T (p2-id x env locals)) + (lambda (p2-lambda x env locals)) + (set! (p2-set! x env locals)) + ;; (if (p2-args (cdr x) env locals)) treat as a primop + ;; (begin (p2-args (cdr x) env locals)) treat as a primop + (letrec (p2-letrec x env locals)) + (else (p2-application x env locals)) + ))) + + (p2-id + (lambda (id env locals) + (when (not (memq id locals)) + (set-id-freeref? id #!true)))) + + (p2-set! + (lambda (x env locals) + (let ((id (set!-id x)) + (val (set!-exp x))) + (set-id-set!? id #!true) + (p2-id id env locals) + (p2-exp val env locals)))) + + (p2-lambda + (lambda (x env locals) + (let ((bvl (lambda-bvl x))) + (when (lambda-closed? x) + (do ((env env (cdr env))) + ((null? env)) + (do ((rib (car env)(cdr rib))) + ((null? rib)) + (set-id-funargsees? (car rib) #!true)))) + (p2-exp (lambda-body x) + (cons bvl env) + bvl)))) + + (p2-letrec + (lambda (x env locals) + (let* ((pairs (letrec-pairs x)) + (bvl (mapcar car pairs)) + (body (letrec-body x)) + (env (cons bvl env)) + (locals (append bvl locals))) + (p2-pairs pairs env locals) + (p2-exp body env locals)))) + + (p2-pairs + (lambda (pairs env locals) + (when pairs + (p2-exp (cadr (car pairs)) env locals) + (p2-pairs (cdr pairs) env locals)))) + + ;; p2-application must process IDs in function position + ;; because they may need to be heap allocated; e.g: + ;; (lambda (f) + ;; (lambda (x) ; 'f' must be heap allocated + ;; (f x))) ; 'f' appears only in function position + + (p2-application + (lambda (x env locals) + (let ((fn (car x))) + (if (or (eq? fn 'THE-ENVIRONMENT) + (eq? fn '%MAKE-HASHED-ENVIRONMENT)) + (smash-the-environment #!true env) + (let ((args (cdr x))) + (when (eq? fn '%CALL/CC) + (smash-the-environment #!false env)) + (p2-args args env locals) + (when (pair? fn) + (if (eq? (car fn) 'LAMBDA) + (p2-exp (lambda-body fn) + (cons (lambda-bvl fn) env) + (lambda-bvl fn)) + (p2-exp fn env locals)))))))) + + ;; (THE-ENVIRONMENT) requires all visible lexical variables + ;; to be heap-allocated + + (smash-the-environment + (lambda (smash-all? env) + (when env + (do ((rib (car env) ; CDR down this rib + (cdr rib))) + ((null? rib)) + (let ((id (car rib)) + (yes #!true)) + (set-id-funargsees? id yes) + (set-id-freeref? id yes) + (when smash-all? + (set-id-set!? id yes) + (close-funarg (id-init id))))) + (smash-the-environment smash-all? (cdr env))))) ; get the next rib + + (p2-args + (lambda (args env locals) + (when args + (p2-exp (car args) env locals) + (p2-args (cdr args) env locals)))) + +;----! + ) + (begin + (p1-exp exp) + (p2-exp exp '() '()) + '())))) ; executed for effect only + + +;================================================================== + \ No newline at end of file diff --git a/newpcs/pchreq.s b/newpcs/pchreq.s new file mode 100644 index 0000000..50aa432 --- /dev/null +++ b/newpcs/pchreq.s @@ -0,0 +1,295 @@ + +; -*- Mode: Lisp -*- Filename: pchreq.s + +; Last Revision: 3-Sep-85 1500ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Character and String Operations ; +; ; +;--------------------------------------------------------------------------; + + +;;;; The operations defined here are those proposed by Chris Hanson on +;;;; 14 Jan 1985 and in a revision on 20 Mar 85. + + +;;;; ------------------- Basic Character Operations -------------------- + +;;; CHAR? PCS primitive (opcode) +;;; CHAR=? PCS primitive (opcode) +;;; CHAR-CI=? PCS primitive (opcode) +;;; CHARINTEGER PCS primitive (opcode) + +(define-integrable char<=? + (lambda (ch1 ch2) + (or (char=? + (lambda (ch1 ch2) + (not (char? + (lambda (ch1 ch2) + (not (or (char=? + (lambda (ch1 ch2) + (not (char-ci? + (lambda (ch1 ch2) + (not (or (char-ciSYMBOL PCS primitive (opcode) +;;; STRING->UNINTERNED-SYMBOL PCS primitive (opcode) +;;; SYMBOL->STRING PCS primitive (opcode) + + +;;;; ----------------------- Standard Operations ----------------------- + + +;;; MAKE-STRING PCS primitive (opcode) +;;; STRING-FILL! PCS primitive (opcode) +;;; SUBSTRING PCS primitive (opcode) + + +(define (string-null? string) ; STRING-NULL? + (and (string? string) + (zero? (string-length string)))) + + +(define string-append ; STRING-APPEND + (letrec + ((sa* + (lambda (s1 s2 rest) + (if (null? rest) + (sa3 s1 '() s2) + (let ((s3 (car rest)) + (rest (cdr rest))) + (if (null? rest) + (sa3 s1 s2 s3) + (sa3 s1 s2 (sa* s3 (car rest)(cdr rest)))))))) + (sa3 + (lambda (s1 s2 s3) + (%string-append s1 0 (string-length s1) + s2 + s3 0 (string-length s3))))) + (lambda args + (cond ((null? args) "") + ((null? (cdr args)) (car args)) + (else (sa* (car args)(cadr args)(cddr args))))))) + + +(define string-copy ; STRING-COPY + (lambda (string) + (%string-append string 0 (string-length string) + '() + "" 0 0))) + + +(define string->list ; STRING->LIST + (lambda (string) + (do ((string string + string) + (index 0 + (add1 index)) + (end (string-length string) + end) + (result '() + (cons (string-ref string index) result))) + ((= index end) + (reverse! result))))) + + +(define (list->string chars) ; LIST->STRING + (do ((chars chars + (cdr chars)) + (index 0 + (add1 index)) + (result (make-string (length chars) '()) + result)) + ((null? chars) result) + (string-set! result index (car chars)))) + + +;;;; ------------------------ Motion Primitives ------------------------ + + +(define (substring-fill! string start end char) ; SUBSTRING-FILL! + (when (< start end) + (string-set! string start char) + (substring-fill! string (1+ start) end char))) + + +(define ; SUBSTRING-MOVE-LEFT! + (substring-move-left! string1 start1 end1 string2 start2) + (when (< start1 end1) + (string-set! string2 start2 + (string-ref string1 start1)) + (substring-move-left! + string1 (1+ start1) end1 string2 (1+ start2)))) + + +(define substring-move-right! ; SUBSTRING-MOVE-RIGHT! + (lambda (string1 start1 end1 string2 start2) + (letrec ((loop + (lambda (count1 count2) + (when (<= start1 count1) + (string-set! string2 count2 + (string-ref string1 count1)) + (loop (-1+ count1) (-1+ count2))))) + (end2 (+ start2 (- end1 start1))) + ) + (loop (-1+ end1) (-1+ end2))))) + + +;;;; ---------------------- Comparison Primitives ---------------------- + + +(define string=? ; STRING=? + (lambda (s1 s2) + (and (string? s1)(string? s2)(eqv? s1 s2)))) + + +(define string=? ; STRING>=? + (lambda (s1 s2) + (not (string? ; STRING>? + (lambda (s1 s2) + (not (string<=? s1 s2)))) + + +(define substring=?) ; SUBSTRING=? +(define substring-ci=?) ; SUBSTRING-CI=? + +(letrec + ((make-substring= + (lambda (char-test) + (lambda (string1 start1 end1 string2 start2 end2) + (define (loop index1 index2) + (or (= index1 end1) + (and (char-test (string-ref string1 index1) + (string-ref string2 index2)) + (loop (1+ index1) (1+ index2))))) + (and (string? string1) + (string? string2) + (= (- end1 start1) (- end2 start2)) + (loop start1 start2)))))) + (begin + (set! substring=? ; SUBSTRING=? + (make-substring= (lambda (a b)(char=? a b)))) + (set! substring-ci=? ; SUBSTRING-CI=? + (make-substring= (lambda (a b)(char-ci=? a b)))))) + + +(define substringnumber as autoload from PNUM2S +; 6/01/87 tc - make compiler re-entrant +; 6/01/87 rb - added more PGR functions to autoload; +; toplevel reworked so RESET doesn't affect the fluids +; INPUT-PORT and OUTPUT-PORT (this allows the system toplevel +; to run in windows other than 'CONSOLE); +; revamped PCS-INITIAL-ARGUMENTS per 3.0 changes to cmd line +; 6/01/87 tc - added MAKE-STRING as autoload for PFUNARG + +;;; +;;; The following functions are related in that they all envoke the +;;; compiler in some form or fashion +;;; +(define load ; LOAD + (lambda (filename) + (let ((i-port (open-input-file filename))) + (if (null? i-port) + (error "Unable to load file" filename) + (letrec + ((loop + (lambda (form) + (cond ((eof-object? form) + (close-input-port i-port) + 'ok) + (else + (eval form) + (loop (read i-port))))))) + (let ((form (read i-port))) + (if (eq? form '#!fast-load) + (begin + (close-input-port i-port) + (fast-load filename)) + (loop form)))))))) + +(define compile-file ; COMPILE-FILE + (lambda (filename1 filename2) + (if (or (not (string? filename1)) + (not (string? filename2)) + (equal? filename1 filename2)) + (%error-invalid-operand-list 'COMPILE-FILE + filename1 + filename2) + (let ((i-port (open-input-file filename1))) + (let ((o-port (open-output-file filename2))) + (set-line-length! 74 o-port) + (letrec + ((loop + (lambda (form) + (if (eof-object? form) + (begin (close-input-port i-port) + (close-output-port o-port) + 'ok) + (begin ; no COMPILE-FORMS + (compile-to-file form) + (set! form '()) ; for GC + (loop (read i-port)))))) + (compile-to-file + (lambda (form) + (let ((cform (compile form))) + (write (list '%execute (list 'quote cform)) + o-port) + (newline o-port) + (%execute cform))))) + (loop (read i-port)))))))) + +(define %compile-timings '()) + +(define %compile ; %COMPILE + (lambda (exp . time?) + (when time? (gc)) + (let ((time '()) + (t0 (runtime))) + (set! pcs-local-var-count 0) + (set! pcs-error-flag #!false) + (set! pcs-verbose-flag (not time?)) + (set! pcs-binary-output #!false) + (set! pme= (pcs-macro-expand exp)) + (if pcs-error-flag + (error "[Compilation terminated because of errors]") + (begin + (set! time (cons (- (runtime) t0) time)) + (set! psimp= (pcs-simplify pme=)) + (set! time (cons (- (runtime) t0) time)) + (pcs-closure-analysis psimp=) + (set! time (cons (- (runtime) t0) time)) + (set! pcg= (pcs-gencode psimp=)) + (set! time (cons (- (runtime) t0) time)) + (set! ppeep= (pcs-postgen pcg=)) + (set! time (cons (- (runtime) t0) time)) + (set! pasm= (pcs-assembler ppeep=)) + (set! time (cons (- (runtime) t0) time)) + (set! pcs-verbose-flag #!false) + (when time? + (set! %compile-timings + (cons (reverse! time) %compile-timings))) + pasm=))))) + +; +; Make compiler re-entrant (or more so, at any rate). The problem arises +; when a macro evokes EVAL and thus COMPILE during macro expansion i9n PME +; +(define compile '()) ; COMPILE + +(let ((ge (%set-global-environment user-global-environment))) + (set! compile + (lambda (exp) + (let* ((vc pcs-local-var-count) ; save + (vf pcs-verbose-flag) + (ef pcs-error-flag) + (bo pcs-binary-output) + (gensym-string (access string (procedure-environment gensym))) + (gensym-counter (access counter (procedure-environment gensym))) + (result (pcs-assembler (pcs-compile-to-AL exp)))) + (set! pcs-local-var-count vc) ; restore + (set! pcs-verbose-flag vf) + (set! pcs-error-flag ef) + (set! pcs-binary-output bo) + (set! (access string (procedure-environment gensym)) gensym-string) + (set! (access counter (procedure-environment gensym)) gensym-counter) + (pcs-clear-registers) + result))) + (%set-global-environment ge)) + +(define pcs-compile-to-AL ; PCS-COMPILE-TO-AL + (lambda (exp) + (set! pcs-local-var-count 0) + (set! pcs-error-flag #!false) + (set! pcs-binary-output #!true) + (set! pcs-verbose-flag #!false) + (let ((t1 (pcs-macro-expand exp))) + (if pcs-error-flag + (error "[Compilation terminated because of errors]") + (begin + (set! exp '()) ; for GC + (pcs-clear-registers) + (let ((t2 (pcs-simplify t1))) + (pcs-closure-analysis t2) + (let ((t3 (pcs-gencode t2))) + (set! t2 '()) ; for GC + (pcs-clear-registers) + (let ((t4 (pcs-postgen t3))) + (pcs-clear-registers) + t4)))))))) + +(define pcs-execute-AL ; PCS-EXECUTE-AL + (lambda (al) + (let ((t1 (pcs-assembler al))) + (pcs-clear-registers) + (%execute t1)))) + +(define optimize! ; OPTIMIZE! + (lambda args + (let ((flag (or (null? args)(car args)))) + (set! pcs-permit-peep-1 flag) + (set! pcs-permit-peep-2 flag)))) + + +;;;; Syntax Checking Functions +;;; +;;; These functions may be used by macros and other syntax transformers +;;; to help find violations of Scheme syntax rules. Note that these +;;; check only the syntax, not semantics, of the program fragments they +;;; are defined for. It is the caller's responsibility, for example, to +;;; verify that all of the identifiers bound in a LETREC are distinct. +;;; PCS-CHK-PAIRS can't do so, because it is called to verify pairs for +;;; both LETREC and LET*. + +(define pcs-chk-id ; PCS-CHK-ID + (lambda (e y) + (when (not (symbol? y)) + (syntax-error "Invalid identifier in expression" y e)))) + +(define (pcs-chk-length= e y n) ; PCS-CHK-LENGTH= + (cond ((and (null? y)(zero? n)) + '()) + ((null? y) + (syntax-error "Expression has too few subexpressions" e)) + ((atom? y) + (syntax-error (if (atom? e) + "List expected" + "Expression ends with `dotted' atom") + e)) + ((zero? n) + (syntax-error "Expression has too many subexpressions" e)) + (else + (pcs-chk-length= e (cdr y) (sub1 n))))) + +(define (pcs-chk-length>= e y n) ; PCS-CHK-LENGTH>= + (cond ((and (null? y)( < n 1)) + '()) + ((atom? y) + (pcs-chk-length= e y -1)) + (else + (pcs-chk-length>= e (cdr y) (sub1 n))))) + +(define (pcs-chk-bvl e bvl dot-ok?) ; PCS-CHK-BVL + (letrec ((oops + (lambda () (syntax-error "Invalid identifier list" e)))) + (cond ((atom? bvl) + (or (null? bvl)(and dot-ok? (pcs-chk-bvar bvl)) + (oops))) + ((pcs-chk-bvar (car bvl)) + (pcs-chk-bvl e (cdr bvl) dot-ok?)) + (else + (oops))))) + +(define (pcs-chk-pairs e pairs) ; PCS-CHK-PAIRS + (letrec ((oops + (lambda () (syntax-error "Invalid pair binding list" e)))) + (if (atom? pairs) + (or (null? pairs) + (oops)) + (let ((pr (car pairs))) + (if (or (atom? pr) + (not (pcs-chk-bvar (car pr))) + (atom? (cdr pr)) + (not (null? (cddr pr)))) + (oops) + (pcs-chk-pairs e (cdr pairs))))))) + + +(define pcs-chk-bvar ; PCS-CHK-BVAR + (lambda (id) + (if (or (not (symbol? id)) + (getprop id 'PCS*MACRO) + (memq id '(QUOTE LAMBDA IF SET! + BEGIN LETREC DEFINE)) + (and (memq id '(T NIL)) + pcs-integrate-t-and-nil)) + (syntax-error "Invalid bound variable name" id) + #!true))) + +;;; EXPAND, EXPAND-MACRO and EXPAND-MACRO-1 expand macro calls. EXPAND-MACRO +;;; and EXPAND-MACRO-1 only expand the outer-level form and leave sub-forms +;;; alone. EXPAND-MACRO-1 does so only once, while EXPAND-MACRO does so +;;; repeatedly until there is no change. EXPAND expands form and all subforms +;;; completely. + +(define expand-macro ; EXPAND-MACRO + (lambda (exp) + (let ((expansion (expand-macro-1 exp))) + (if (or (atom? exp) (equal? expansion exp)) + expansion + (expand-macro expansion))))) + +(define expand-macro-1 ; EXPAND-MACRO-1 + (lambda (x) + (cond ((symbol? x) + (let ((entry (getprop x 'PCS*MACRO))) + (if (null? entry) + x + (if (pair? entry) + (if (eq? (car entry) 'ALIAS) + (cdr entry)) + (syntax-error "Macro or special form name used as a variable" + x))))) + ((pair? x) + (let* ((f (car x)) + (ef (if (pair? f) (expand-macro f) f)) + (a (cdr x))) + (if (symbol? ef) + (let ((macfun (getprop ef 'PCS*MACRO))) + (cond ((null? macfun) + (cons ef a)) + ((pair? macfun) + (cons (cdr macfun) a)) + (else + (macfun (cons ef a))))) + (cons ef a)))) + (else x)))) + +(define expand ; EXPAND + (letrec ((expand-item + (lambda (item) + (if (pair? item) (expand item) item)))) + (lambda (exp) + (let ((expansion (expand-macro exp))) + (map expand-item expansion))))) + +;;; +;;; Set up EDWIN so that it may be loaded into its own environment +;;; + +(define initiate-edwin ; INITIATE-EDWIN + (lambda () + (unbind 'edwin user-global-environment) + (set! (access edwin-environment user-global-environment) + (make-hashed-environment)) + (%reify! edwin-environment 0 user-initial-environment) + (autoload-from-file (%system-file-name "edwin0.fsl") + '(edwin) + edwin-environment) + (edwin))) + +(define edwin initiate-edwin) ; EDWIN + +;;; +;;; Set up compiler-related global variables +;;; + +(BEGIN + (define %pcs-stl-debug-flag #!false) + (define %pcs-stl-history '(%PCS-STL-HISTORY)) ; getprop tag + (define pcs-local-var-count 0) + (define pcs-integrate-integrables #!true) + (define pcs-integrate-primitives #!true) + (define pcs-integrate-T-and-NIL #!true) + (define pcs-integrate-define #!true) + (define pcs-debug-mode #!false) ; debug mode OFF + (define pcs-permit-peep-1 #!true) ; optimization ON + (define pcs-permit-peep-2 #!true) + (define pcs-verbose-flag #!false) + (define pcs-display-warnings #!true) + (define pme= '()) + (define psimp= '()) + (define pcg= '()) + (define ppeep= '()) + (define pasm= '()) +) + +;;; Evaluation + +;;; EVAL is part interpreter, but calls the compiler for complicated +;;; expressions. In particular, it does not do any bindings +;;; interpretively, since they would have to be first-class +;;; environments and the compiler might be able to do better. + +(define eval + (letrec + ((eval-exp + (lambda (xx env) + (let ((x (expand-macro xx))) + (if (pair? x) + (case (car x) + ((QUOTE) (eval-quote x env)) + ((IF) (eval-if x env)) + ((SET!) (eval-set! x env)) + ((DEFINE) (eval-define x env)) + ((BEGIN) (eval-begin x env)) + ((LET + LET* + LETREC + LAMBDA ) (eval-compile x env)) + ((%%GET-FLUID%%) (eval-fluid x env)) + ((%%SET-FLUID%%) (eval-set-fluid! x env)) + ((THE-ENVIRONMENT) env) + ((PCS-CODE-BLOCK) (eval-execute x env)) + (else (eval-application x env))) + (eval-atom x env))))) + + (lookup-binding ; LOOKUP-BINDING + (lambda (sym) + ; The following is the object code to lookup/fetch + ; the binding of sym. It must be passed to %execute with + ; the desired environment. + (list 'pcs-code-block 1 4 (list sym) + '( 7 4 0 ; Ld-global r1,sym + 59)))) ; exit + + (eval-atom ; EVAL-ATOM + (lambda (x env) + (cond ((not (symbol? x)) x) + ((memq x '(#!TRUE #!FALSE #!UNASSIGNED)) x) + (else + (let ((entry (and PCS-INTEGRATE-T-AND-NIL + (assq x '((T #T) (NIL #F)))))) + (if entry + (cadr entry) + ;else + (or (lookup-integrable x env) + (eval-execute (lookup-binding x) env)))))))) + + (lookup-integrable + (lambda (x env) + (let ((info (getprop x 'PCS*PRIMOP-HANDLER))) + (and info + (pair? info) + (eval-exp (cdr info) env))))) + + (eval-quote ; EVAL-QUOTE + (lambda (x env) + (pcs-chk-length= x x 2) + (cadr x))) + + (eval-id-error + (lambda (err caller env) + (syntax-error + (string-append "Invalid identifier for " caller ": ") err))) + + + (eval-if ; EVAL-IF + (lambda (x env) + (if (or (atom? (cdr x)) ; No Pred + (atom? (cddr x)) ; No Then + (pair? (cdddr x))) ; has ELSE + (pcs-chk-length= x x 4) + (pcs-chk-length= x x 3)) + (cond ((eval-exp (cadr x) env) + (eval-exp (caddr x) env)) + ((pair? (cdddr x)) + (eval-exp (cadddr x) env)) + (else + #!FALSE)))) + + + (set-var-value ; SET-VAR-VALUE + (lambda (sym value) + ; The following is the object code code to set the value + ; of a variable. It must be passed to %execute with the + ; desired environment. + (list 'pcs-code-block 2 7 (list sym value) + '( 1 4 1 ; Load r1, value + 15 4 0 ; St-glob-env r1,sym + 59)))) ; exit + + (eval-set! ; EVAL-SET! + (lambda (x env) + (pcs-chk-length= x x 3) + (let* ((id (cadr x)) + (var (expand-macro id)) + (value (eval-exp (caddr x) env))) + (cond ((not (pair? var)) + (cond ((or (not (symbol? var)) + (not (eq? var (expand-macro var)))) + (eval-id-error var "SET!" env)) + ((getprop var 'PCS*PRIMOP-HANDLER) + ; this is for primitives and define-integrables + (eval-compile x env)) + (else + (eval-execute (SET-VAR-VALUE var value) env)))) + (else + (eval-id-error var "SET!" env)))))) + + (def-var ; DEF-VAR + (lambda (sym value) + ; The following is the object code code to define a variable + ; in a given environment. It must be passed to %execute with the + ; desired environment. + (list 'pcs-code-block 2 7 (list sym value) + '( 1 4 1 ; Load r1, value + 31 4 0 ; define! value,sym + 59)))) ; exit + + (eval-define ; EVAL-DEFINE + (lambda (x env) + (pcs-chk-length>= x x 3) + (if (and (pair? (caddr x)) + (memq (caaddr x) '(LAMBDA NAMED-LAMBDA))) + (eval-compile x env) + ;else + (let* ((id (cadr x)) + (var (expand-macro id)) + (value (eval-exp (caddr x) env))) + (cond ((not (pair? var)) + (cond ((or (not (symbol? var)) + (not (eq? var (expand-macro var)))) + (eval-id-error var "DEFINE" env)) + ((getprop var 'PCS*PRIMOP-HANDLER) + ; this is for primitives and define-integrables + (eval-compile x env)) + (else + (eval-execute (DEF-VAR var value) env) + id))) + (else + (eval-id-error var "DEFINE" env))))))) + + + (eval-begin ; EVAL-BEGIN + (lambda (x env) + (pcs-chk-length>= x x 1) + (let loop ((x (cdr x))) + (if (null? (cdr x)) + (eval-exp (car x) env) + (begin + (eval-exp (car x) env) + (loop (cdr x))))))) + + (lookup-fluid ; LOOKUP-FLUID + (lambda (sym) + ; The following is the object code to lookup/fetch the + ; fluid binding of sym. It must be passed to %execute with + ; the desired environment. + (list 'pcs-code-block 1 4 (list sym) + '( 8 4 0 ; Ld_fl r1,sym + 59)))) ; exit + + (eval-fluid ; EVAL-FLUID + (lambda (x env) + (pcs-chk-length= x x 2) + (eval-execute (lookup-fluid (eval-exp (cadr x) env)) env))) + + (set-fluid-var ; SET-FLUID-VAR + (lambda (sym value) + ; The following is the object code to set the value of a + ; fluid variable. It must be passed to %execute with the + ; desired environment. + (list 'pcs-code-block 2 7 (list sym value) + '( 1 4 1 ; Load r1, value + 16 4 0 ; St-fl r1,sym + 59)))) ; exit + + (eval-set-fluid! ; EVAL-SET-FLUID! + (lambda (x env) + (pcs-chk-length>= x x 2) + (let ((sym (eval-exp (cadr x) env)) + (val (eval-exp (caddr x) env))) + (pcs-chk-id x sym) + (eval-execute (set-fluid-var sym val) env)))) + + (eval-application ; EVAL-APPLICATION + (lambda (x env) + (pcs-chk-length>= x x 1) + (let ((proc (eval-exp (car x) env))) + (when (not (or (procedure? proc) + (and (pair? proc) + (eq? (car proc) 'LAMBDA)))) + (error-procedure "Attempt to call a non-procedural object" + (cons proc (cdr x)) + env)) + (let ((args (eval-args (cdr x) env))) + (let* ((saved-env (%set-global-environment env)) + (result (apply proc args))) + (%set-global-environment saved-env) + result))))) + + (eval-args ; EVAL-ARGS + (lambda (x env) + (if (null? x) + '() + (cons (eval-exp (car x) env) + (eval-args (cdr x) env))))) + + (eval-compile ; EVAL-COMPILE + (lambda (x env) + (eval-execute (compile x) env))) + + (eval-execute ; EVAL-EXECUTE + (lambda (x env) + (let* ((saved-env (%set-global-environment env)) + (result (%execute x))) + (%set-global-environment saved-env) + result))) + + ) ; letrec vars + + (lambda (exp . rest) + (let* ((env (cond ((null? rest) + (let ((e (%set-global-environment + user-initial-environment))) + (%set-global-environment e) + e)) + ((not (environment? (car rest))) + (%error-invalid-operand 'EVAL (car rest))) + (else + (car rest)))) + (result (eval-exp exp env))) + result)))) + + \ No newline at end of file diff --git a/newpcs/pdebug.s b/newpcs/pdebug.s new file mode 100644 index 0000000..cfe6032 --- /dev/null +++ b/newpcs/pdebug.s @@ -0,0 +1,411 @@ +; -*- Mode: Lisp -*- Filename: pdebug.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; System Debugger and Error Handlers ; +; ; +;--------------------------------------------------------------------------; + +; Revision history: +; db 10/18/85 - ?? +; tc 03/13/87 - Extended errors for DOS I/O errors + + +; The following definitions are used only at compile time for readability +; and understanding. They will not be written out to the .so file. +; See pboot.s and compile.all. + +(compile-time-alias IO-ERRORS-START 21) +(compile-time-alias IO-ERRORS-END 108) +(compile-time-alias DOS-IO-ERROR 21) +(compile-time-alias FILE-NOT-FOUND 22) +(compile-time-alias PATH-NOT-FOUND 23) +(compile-time-alias TOO-MANY-FILES 24) + +(define assert-procedure) +(define breakpoint-procedure) +(define error-procedure) +(define *error-handler*) + +(letrec + ((uv-msg + '(1 2 3 4)) + (msg-codes + '((0 . "Unspecified VM error") + (1 . "Variable not defined in current environment") + (2 . "SET! of an unbound variable") + (3 . "Variable not defined in lexical environment") + (4 . "SET! of an unbound lexical variable") + (5 . "Variable not defined in fluid environment") + (6 . "SET-FLUID! of an unbound fluid variable") + (7 . "Vector index out of range") + (8 . "String index out of range") + (9 . "Invalid substring range") ; not generated + (10 . "Invalid operand to VM instruction") + (11 . "User keyboard interrupt") + (12 . "Attempt to call a non-procedural object") + ;; (13 . "Engine Timer Interrupt") + (14 . "I/O attempted to a de-exposed window") + ;; 14 is a trap for a window handler, not a real error + (15 . "FLONUM overflow or underflow") + (16 . "Divide by zero") + (17 . "Non-numeric operand to arithmetic operation") + (18 . "Register overflow--Too many arguments to closure") + (19 . "MAKE-VECTOR size limit exceeded") + (20 . "MAKE-STRING size limit exceeded") + (21 . "DOS I/O error number ") + (22 . "DOS I/O error - File not found") + (23 . "DOS I/O error - Path not found") + (24 . "DOS I/O error - Too many open files") + (25 . "DOS I/O error - Access denied") + (32 . "DOS I/O error - Invalid access") + (36 . "DOS I/O error - Invalid disk drive") + (39 . "DOS I/O error - Disk write protected") + (41 . "DOS I/O error - Drive not ready") + (48 . "DOS I/O error - Printer out of paper") + (200 . "DOS I/O error - Disk Full") + )) + (oops + (lambda (msg irritant env stk-index kind error-code) + (fluid-let ((input-port standard-input) + (output-port standard-output)) + (let* ((si (if (negative? stk-index) + (%reify-stack (+ (%reify-stack -1) 6)) + stk-index)) + (env (if (null? env) + (%reify-stack (+ si 9)) + env))) + (newline) + (display kind) + (when msg (display msg)) + (newline) + (write irritant) + (newline) + (pcs-kill-engine) + + (if (unbound? compile) + ;; see if compiler auto-loadable + (when (not (pcs-autoload-binding 'compile)) + ;; Cant find compiler, punt + (display (integer->char 7)) ;beep + (display "Press a key to return to toplevel, escape to exit to DOS") + (let ((ch (read-char))) + (if (char=? ch #\escape) + (exit) + (scheme-reset)))) + ;else + (if (null? (%env-lu '%inspector user-initial-environment)) + ;; check to see if we can load the inspector + (when (or (eqv? *error-message* TOO-MANY-FILES) + (null? (pcs-autoload-binding '%inspector))) + (display "Unable to autoload the inspector - file PINSPECT.FSL") + (reset)))) + + (%inspector msg kind irritant env si error-code) + + )))) + (envoke-handler + (lambda (number msg irritant stk-index err-code) + (let ((handler (lambda () + (oops msg + irritant + '() + stk-index + "[VM ERROR encountered!] " + err-code)))) + (if (closure? *user-error-handler*) + (*user-error-handler* number + msg + irritant + handler) + (handler))))) + (decipher-error + (lambda (stk-index) + (let ((err-code *error-code*) + (irritant *irritant*) + (err-num (and (number? *error-message*) *error-message*)) + (msg (apply-if (assv *error-message* msg-codes) + cdr + *error-message*))) + (cond ((eqv? err-num 11) ; Shift Break + (set! err-num 100)) + ((and err-num ; I/O Errors + (>= err-num IO-ERRORS-START) + (<= err-num IO-ERRORS-END)) + (if (and (or (=? err-num FILE-NOT-FOUND) + (=? err-num PATH-NOT-FOUND)) + (fluid-bound? *file-exists-open*)) + ((fluid *file-exists-open*) #!false)) ; error continuation + + (set! err-num (- err-num (-1+ DOS-IO-ERROR))) + (if (number? msg) + (set! msg (string-append (cdr (assv DOS-IO-ERROR msg-codes)) + (integer->string err-num 10)))))) + (envoke-handler err-num msg irritant stk-index err-code)))) + ) ; letrec vars + + (begin + (set! assert-procedure ; ASSERT-PROCEDURE + (lambda (msgs env) + (oops '() (cons 'ASSERT (cons '() msgs)) env -1 "[ASSERT failure!] " 0))) + + (set! breakpoint-procedure ; BREAKPOINT-PROCEDURE + (lambda (msg irritant env . rest) + (let* ((stk-index (if (or (null? rest) + (not (integer? (car rest)))) + -1 + (car rest)))) + (oops msg irritant env stk-index "[BKPT encountered!] " 0)))) + + (set! error-procedure ; ERROR-PROCEDURE + (lambda (msg irritant env) + (let ((system-error-handler + (lambda () + (oops msg irritant env -1 "[ERROR encountered!] " 0)))) + (if (closure? *user-error-handler*) + (begin + (*user-error-handler* '() msg irritant system-error-handler)) + ;else + (system-error-handler))))) + + (set! *error-handler* ; *ERROR-HANDLER* + (lambda () + (cond ((and (zero? *error-code*) ; resumable + (memv *error-message* uv-msg)) ; unbound symbol + (if (pcs-autoload-binding *irritant*) + '() ; autoload worked! + ;else + (let ((info (getprop *irritant* 'PCS*PRIMOP-HANDLER)) + (compiler-present (or (not (unbound? compile)) + (pcs-autoload-binding 'compile)))) + (cond ((and compiler-present + (integer? info) + (getprop *irritant* 'PCS*OPCODE)) + (let* ((vars '(J I H G F E D C B A)) + (bvl (list-tail vars (- (length vars) info))) + (form `(define ,*irritant* + (lambda ,bvl + (,*irritant* . ,bvl)))) + (dw pcs-display-warnings) + (ip pcs-integrate-primitives)) + (set! pcs-display-warnings #!false) + (set! pcs-integrate-primitives #!true) + (eval form user-global-environment) + (set! pcs-display-warnings dw) + (set! pcs-integrate-primitives ip) + '())) + ((and compiler-present + (pair? info) + (eq? (car info) 'DEFINE-INTEGRABLE)) + (let ((form `(define ,*irritant* ,(cdr info))) + (dw pcs-display-warnings) + (ip pcs-integrate-primitives)) + (set! pcs-display-warnings #!false) + (set! pcs-integrate-primitives #!true) + (eval form user-initial-environment) + (set! pcs-display-warnings dw) + (set! pcs-integrate-primitives ip) + '())) + (else + (set! *error-message* + (cdr (assv *error-message* msg-codes))) + (*error-handler*)))))) + ((eqv? *error-message* 13) + (pcs-engine-timeout)) ; Engine Timeout + (else + (decipher-error (%reify-stack + (+ (%reify-stack + (+ (%reify-stack -1) 6)) 6))))) + ) ;lambda + ) ;set! + ) ;begin +) ;letrec + +(define autoload-from-file ; AUTOLOAD-FROM-FILE + (lambda (file names . rest) + (let ((env (if rest (car rest) user-initial-environment))) + (putprop 'PCS-AUTOLOAD-INFO + (cons (list file names env) + (getprop 'PCS-AUTOLOAD-INFO + 'PCS-AUTOLOAD-INFO)) + 'PCS-AUTOLOAD-INFO) + '()))) + + + +(define pcs-autoload-binding '()) ; PCS-AUTOLOAD-BINDING +(define remove-autoload-info '()) ; REMOVE-AUTOLOAD-INFO + +(letrec + ((find-entry + (lambda (name info) + (and info + (or (symbol? name) (string? name)) + (find-item name (caar info)(cadar info) info)))) + (find-item + (lambda (name file symbols info) + (cond ((string? name) + (if (string-ci=? name file) + (car info) + (find-entry name (cdr info)))) + ((null? symbols) + (find-entry name (cdr info))) + ((eq? name (car symbols)) + (car info)) + (else + (find-item name file (cdr symbols) info)))))) + (set! pcs-autoload-binding + (lambda (name) + (let* ((info (getprop 'PCS-AUTOLOAD-INFO 'PCS-AUTOLOAD-INFO)) + (entry (find-entry name info))) + (and entry + (let ((file (car entry)) + (env (caddr entry))) + (and (string? file) + (file-exists? file) + (let ((saved-env (%set-global-environment env))) + (load file) + (%set-global-environment saved-env) + (not (null? (%env-lu name env))) + ))))))) + (set! remove-autoload-info + (lambda (filename) + (let* ((info (getprop 'PCS-AUTOLOAD-INFO 'PCS-AUTOLOAD-INFO)) + (entry (find-entry (%system-file-name filename) info))) + (and entry + (putprop 'PCS-AUTOLOAD-INFO + (delq! entry + (getprop 'PCS-AUTOLOAD-INFO + 'PCS-AUTOLOAD-INFO)) + 'PCS-AUTOLOAD-INFO))))) +) + +(define environment-bindings ; ENVIRONMENT-BINDINGS + (letrec + ((linked-bindings + (lambda (a-list names values) + (if (null? names) + (reverse! a-list) + (linked-bindings (cons (cons (car names)(cdr values)) + a-list) + (cdr names) + (car values))))) + (hashed-bindings + (lambda (a-list index env) + (if (zero? index) + a-list + (let ((bucket (%reify env index))) + (hashed-bindings (if (null? bucket) + a-list + (bucket-bindings a-list bucket)) + (- index 1) + env))))) + (bucket-bindings + (lambda (a-list bucket) + (if (null? bucket) + a-list + (bucket-bindings (cons (car bucket) a-list) + (cdr bucket)))))) + (lambda (obj) + (if (null? obj) + obj + (let* ((env (cond ((environment? obj) ; environment? + obj) + ((or (closure? obj) ; closure? + (delayed-object? obj)) ; delayed object? + (procedure-environment obj)) + (else + (%error-invalid-operand 'ENVIRONMENT-BINDINGS + obj)))) + (size (%reify env -1))) + (if (= size 12) + (linked-bindings '() (%reify env 1) (%reify env 2)) + (hashed-bindings '() (- (quotient size 3) 2) env))))))) + + +;;; +;;; UNBIND is a function which will remove a variable's binding from a given +;;; environment. It will work for either of the 2 global environments +;;; (USER-GLOBAL-ENVIRONMENT and USER-INITIAL-ENVIRONMENT) or for any other +;;; heap allocated environments. Removing the binding from the environment +;;; will allow the garbage collector to reclaim that space. Also, once +;;; unbound, the autoloader may reload the variable whenever that variable +;;; is referenced again. +;;; + + +(define unbind + (letrec + ((remove-hashed-binding! + (lambda (key alist) + (cond ((null? (cadr alist)) + '()) + ((eq? key (caadr alist)) + (set-cdr! alist (cddr alist))) + (else + (remove-hashed-binding! key (cdr alist)))))) + + (modify-hashed-env! + (lambda (symbol env) + (let* ((hash-val (1+ (%esc2 9 (symbol->string symbol)))) + (sym-list (%reify env hash-val))) + + (if (null? sym-list) + '() + ;else + (begin + (if (eq? symbol (caar sym-list)) + (set! sym-list (cdr sym-list)) + ;else + (remove-hashed-binding! symbol sym-list)) + (%reify! env hash-val sym-list) + env))))) + + (remove-linked-binding! + (lambda (key names values) + (cond ((null? (cadr names)) + '()) + ((eq? key (cadr names)) + (set-cdr! names (cddr names)) + (set-car! values (caar values))) + (else + (remove-linked-binding! key (cdr names) (car values)))))) + + (modify-linked-env! + (lambda (symbol env names values) + (if (eq? symbol (car names)) + (begin + (set! names (cdr names)) + (set! values (car values))) + ;else + (remove-linked-binding! symbol names values)) + (%reify! env 1 names) + (%reify! env 2 values))) + ) + + (lambda (symbol env) + (cond ((not (symbol? symbol)) + (%error-invalid-operand 'UNBIND symbol)) + ((not (environment? env)) + (%error-invalid-operand 'UNBIND env)) + (else + (if (= (%reify env -1) 12) + (modify-linked-env! symbol env (%reify env 1) (%reify env 2)) + ; + (modify-hashed-env! symbol env))))))) + + +(define (procedure-environment obj) ; PROCEDURE-ENVIRONMENT + (cond ((closure? obj) + (%reify obj 1)) + ((delayed-object? obj) + (procedure-environment (vector-ref obj 1))) + (else + (%error-invalid-operand 'PROCEDURE-ENVIRONMENT obj)))) + + \ No newline at end of file diff --git a/newpcs/pdefstr.s b/newpcs/pdefstr.s new file mode 100644 index 0000000..6b133a8 --- /dev/null +++ b/newpcs/pdefstr.s @@ -0,0 +1,210 @@ + +; -*- Mode: Lisp -*- Filename: pdefstr.s + +; Last Revision: 30-Aug-85 1900ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; Amitabh Srivastava ; +; ; +; DEFINE-STRUCTURE and Related Routines ; +; ; +;--------------------------------------------------------------------------; + +;;; +;;; - syntax is similar to DEFSTRUCT in Common Lisp +;;; +;;; Syntax : (DEFINE-STRUCTURE name slot1 slot2 ...) +;;; +;;; slots may be given default values by (slot1 init-val) +;;; +;;; e.g (DEFINE-STRUCTURE SHIP (X-VEL 0) Y-VEL) +;;; +;;; objects of this structure can be generated by using +;;; MAKE-SHIP - +;;; +;;; (MAKE-SHIP 'X-VEL 10) +;;; +;;; the predicate SHIP? can be used to check if an object is an +;;; instance of ship. +;;; +;;; (SHIP-X-VEL object) can be used to get the `x-vel' of the object, +;;; which is an instance of `ship' +;;; +;;; (SET! (SHIP-X-VEL object) 11) can be used to set the `x-vel' of the +;;; object. +;;; +;;; single-inheritance : structures can inherit from other objects by +;;; using the INCLUDE option (similar to Common Lisp DEFSTRUCT) +;;; +;;; e.g. (DEFINE-STRUCTURE (SHIP (INCLUDE FLOATING-OBJECT)) slot ...) +;;; + + + +;;; Implementation Note + + +;;; The Common Lisp definition requires that the slot initialization +;;; expressions be re-evaluated each time a MAKE-name operation is +;;; performed. For consistency with the spirit of Scheme, these +;;; expressions should be evaluated in the lexical environment surrounding +;;; the DEFINE-STRUCTURE itself. Thus, DEFINE-STRUCTURE must expand into +;;; at least one LAMBDA that `freezes' the initialization expressions. +;;; This is why %DEFINE-STRUCTURE expands into a BEGIN with an embedded +;;; closure for MAKE-name. (This is important only if an initialization +;;; expression involves lexical references.) + + + +;;; Global function used to generate predicates for all structures + + +(define %structure-predicate ; %STRUCTURE-PREDICATE + (lambda (object tag) + (and (vector? object) + (positive? (vector-length object)) + (member tag (vector-ref object 0)) + #!true))) + + +;;; %MAKE-STRUCTURE is used by all structures to create an instance + + +(define %make-structure ; %MAKE-STRUCTURE + (lambda (name constructor-name structure init-list) + (letrec ((slot-number + (lambda (slot slot-values) + (apply-if (assq slot slot-values) + cadr + (error (string-append + "Structure component unknown to " + (symbol->string constructor-name)) + slot))))) + (let ((slots (getprop name '%SLOT-VALUES))) + (do ((structure structure) + (init-msg init-list (cddr init-msg))) + ((null? init-msg) structure) + (vector-set! structure + (slot-number (car init-msg) slots) + (cadr init-msg))))))) + + +;;; %DEFINE-STRUCTURE defines a structure with specified attributes. This +;;; is the procedure that expands the macro DEFINE-STRUCTURE. + + +(define %define-structure ; %DEFINE-STRUCTURE + (lambda (e) + (letrec + ((make-symbol ; MAKE-SYMBOL + (lambda args + (string->symbol (apply string-append args)))) + + (generate-slots-loop ; GENERATE-SLOTS-LOOP + (lambda (tail slots n) + (if (null? slots) + tail ;;; 2/14/86 + (generate-slots-loop + (cons (if (atom? (car slots)) + (cons (car slots) (cons n '())) + (cons (caar slots) (cons n (cadar slots)))) + tail) + (cdr slots) + (1+ n))))) + + (generate-slots ; GENERATE-SLOTS + (lambda (include-struct slots) + (if include-struct + (let ((include-slots (getprop include-struct '%SLOT-VALUES))) + (generate-slots-loop include-slots + slots + (1+ (length include-slots)))) + (generate-slots-loop '() slots 1)))) + + (init-slots ; INIT-SLOTS + (lambda (slots) + (let loop ((tail '()) + (slots slots)) + (if (null? slots) + tail + (loop (if (member (cddar slots) '(() '())) + tail + (cons `(vector-set! %DS0001% ,(cadar slots) + ,(cddar slots)) + tail)) + (cdr slots)))))) + + (access-macros-loop ; ACCESS-MACROS-LOOP + (lambda (name-string slots tail) + (if (null? slots) + (reverse! tail) + (access-macros-loop + name-string + (cdr slots) + (let ((name (make-symbol name-string "-" + (symbol->string (caar slots)))) + (index (cadar slots))) + (cons `(define-integrable ,name + (lambda (obj) (vector-ref obj ,index))) + tail)))))) + + (gen-access-macros ; GEN-ACCESS-MACROS + (lambda (name-string slot-names-pos) + (access-macros-loop name-string slot-names-pos '()))) + + (gen-make-proc ; GEN-MAKE-PROC + (lambda (name constructor-name slot-names-pos) + `(define ,constructor-name + (lambda %DS0002% + (let ((%DS0001% (make-vector ,(1+ (length slot-names-pos)) + '()))) + (vector-set! %DS0001% 0 (getprop ',name '%TAG)) + ,@(init-slots slot-names-pos) + (if (null? %DS0002%) + %DS0001% + (%make-structure ',name ',constructor-name + %DS0001% %DS0002%))))))) + ) + (begin + (pcs-chk-length>= e e 2) + (let* ((name-options (cadr e)) + (name (let ((n (if (atom? name-options) + name-options + (car name-options)))) + (pcs-chk-id e n) + n)) + (name-string (symbol->string name)) + (constructor-name (make-symbol "MAKE-" name-string)) + (predicate-name (make-symbol name-string "?")) + (include-struct + (cond ((atom? name-options) + '()) + ((and (pair? (cdr name-options)) + (pair? (cadr name-options)) + (eq? (car (cadr name-options)) 'INCLUDE) + (pair? (cdr (cadr name-options)))) + (let ((is (cadr (cadr name-options)))) + (pcs-chk-id e is) + is)) + (else + (syntax-error "Invalid option list" e)))) + (slots (cddr e)) + (slot-names-pos (generate-slots include-struct slots)) + (tag (cons '#!STRUCTURE name)) + (complex-tag (if include-struct + (cons tag (getprop include-struct '%TAG)) + (list tag)))) + `(begin + (putprop ',name ',complex-tag '%TAG) + (putprop ',name ',slot-names-pos '%SLOT-VALUES) + ,@(gen-access-macros name-string slot-names-pos) + (define ,predicate-name + (lambda (obj) + (%structure-predicate obj ',tag))) + ,(gen-make-proc name constructor-name slot-names-pos) + ',name)))))) + \ No newline at end of file diff --git a/newpcs/pdos.s b/newpcs/pdos.s new file mode 100644 index 0000000..8f2615b --- /dev/null +++ b/newpcs/pdos.s @@ -0,0 +1,422 @@ + +; -*- Mode: Lisp -*- Filename: pdos.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; DOS Interface Routines ; +; ; +;--------------------------------------------------------------------------; + +;;; Revision history: +;;; ds 6/ 5/86 - added new file and directory functions +;;; rb 7/16/86 - DOS-CALL checks for .COM and .EXE files +;;; ds 12/08/86 - fixed a problem with dos-rename not correctly reseting the +;;; destination drive correctly. + +;;; The following Scheme function implements a directory listing +;;; capability. DOS-DIR is called with an MS-DOS filename specifier +;;; which may contain wildcard characters, and returns a list of +;;; the filenames which match the filespec. For example, +;;; +;;; (DOS-DIR "\\pcs\\*.exe") +;;; +;;; might return the list: +;;; +;;; ("PCS.EXE" "MAKE_FSL.EXE") +;;; +;;; Remember that Scheme requires the backslash character "\" to be +;;; escaped, so you must specify two "\\"'s in a character string if +;;; you want to see one "\". + +(begin + +(define dos-dir + (lambda (filespec) + (letrec ((dir1 (lambda () + (let ((next (%esc1 1))) + (if next + (cons next (dir1)) + '()))))) + (if (string? filespec) + (let ((next (%esc2 0 filespec))) + (if next + (cons next (dir1)) + '() )) + (%error-invalid-operand 'DOS-DIR filespec) )))) + + +;;; The DOS-CALL function permits a user to issue any MS-DOS command from +;;; Scheme and return when the function has completed. The format for +;;; the DOS-CALL function is: +;;; +;;; (dos-call "filename" "parameters" +;;; {memory} {protect display}) +;;; +;;; where "filename" is the name of an .EXE or .COM file which is to +;;; be executed. If "filename" is a null (zero length) +;;; string (i.e., ""), the "parameters" string is +;;; passed to a new copy of COMMAND.COM. +;;; +;;; "parameters" is the parameter string to be passed to the +;;; application or COMMAND.COM. +;;; +;;; If both "filename" and "parameters" are null +;;; strings, DOS-CALL exits to MS-DOS COMMAND.COM and +;;; stays there until the command EXIT is entered, at +;;; which time PCS execution resumes. +;;; +;;; "memory" is an optional argument which specifies the number +;;; of paragraphs (16 byte units of memory) which are +;;; to be freed up to run the requested task. If this +;;; argument is omitted, all available Scheme user +;;; memory is made available to the task. Note: +;;; 4096 paragraphs is equivalent to 64K bytes of +;;; memory. +;;; +;;; "protect display" is an optional argument which allows the current +;;; screen to be left undisturbed when the external program +;;; is being executed. Note: this will only inhibit text +;;; from being displayed to the screen for programs doing +;;; screen i/o that doesn't bypass the BIOS (Lotus 1-2-3 +;;; does). +;;; +;;; Scheme memory is freed up by copying it to disk in 4095 paragraph +;;; (65,520 byte) blocks. Specifying 4095 paragraphs instead of 4096 (to +;;; make it an even 64K bytes) saves a slight bit of disk I/O overhead. +;;; +;;; The value returned by DOS-CALL is an integer error code. Zero +;;; indicates no error; -1 indicates an argument error; positive values +;;; are those returned by DOS itself. + + +(define dos-call + (lambda args + (define extension-sans-filename + ;given filename of form "file.ext" (leading directories are allowed) + ;return extension ".ext" or empty string if none + (lambda (file) + (let ((period (substring-find-next-char-in-set + file 0 (string-length file) "."))) + (if period + (substring file period (string-length file)) + "")))) + (let ((filename (if args (car args) "")) + (parameters (if (and args (cadr args)) (cadr args) "")) + (mem_req (if (cddr args) (car (cddr args)) 0)) + (protect (if (= (length (cddr args)) 2) (cadr (cddr args)) 0)) + (temp-window (%make-window '())) + (window-contents '())) + ;body of DOS-CALL + (if (and (string? filename) + (string? parameters) + (cond ((string-null? filename)) ;null name means just go to DOS + ((string-ci=? (extension-sans-filename filename) ".COM")) + ((string-ci=? (extension-sans-filename filename) ".EXE")) + (t nil))) ;any other extension illegal + (begin + (if (eqv? protect 0) + (begin + (set! window-contents (%save-window temp-window)) + (%clear-window temp-window))) + (begin0 + (%esc5 + 2 + filename + (if (eqv? filename "") + (if (eqv? parameters "") + (list->string (list (integer->char 0) + (integer->char 13))) + (string-set! + (string-append + (string-append "x/c " parameters) + (make-string 1 #\return)) + 0 + (integer->char (+ (string-length parameters) 3)))) + (string-set! + (string-append + (string-append "x" parameters) + (make-string 1 #\return)) + 0 + (integer->char (string-length parameters)))) + (truncate mem_req) + protect) + + (if (eqv? protect 0) + (begin + (let ((cur_pos (window-get-cursor 'console))) + (%clear-window 'console) + (window-set-cursor! 'console (car cur_pos) (cdr cur_pos)) + (%restore-window temp-window window-contents)))) + )) + -1)))) ; error + + +;;; The following Scheme function implements a software interrupt +;;; capability. SW-INT is called with an interrupt number between +;;; 0 and 255, a return result value, and up to four values which +;;; will be stuffed into the registers ax,bc,cx,and dx. +;;; +;;; Possible values for the return result are: +;;; 0 - INTEGER +;;; 1 - T OR NIL +;;; 2 - STRING +;;; +;;; (SW-INT 112 0 100 "hello") - +;;; Invokes interrupt 112 (or 70 hex). Register ax will be loaded +;;; with a pointer to 100, bx will be loaded with a pointer to +;;; the string "hello" and registers cx and dx are not used. The +;;; return value is expected to be an integer. (return values are +;;; handled the same way that Lattice C expects results from assembly +;;; language programs.) +;;; + +(define sw-int + (lambda args + (let ((int_num (car args)) + (return_type (cadr args)) + (ax (if (null? (cddr args)) "" (caddr args))) + (bx (if (null? (cdddr args)) "" (cadddr args))) + (cx (if (null? (cddddr args)) "" (car (cddddr args)))) + (dx (if (null? (cdr(cddddr args))) "" (cadr(cddddr args))))) + (if (> (length args) 6) + (apply %error-invalid-operand-list (cons 'SW-INT args)) + ;else + (if (or (< int_num 0) (> int_num 255)) + (%error-invalid-operand 'SW-INT int_num) + ;else + (if (> return_type 3) + (%error-invalid-operand 'SW-INT return_type) + ;else + (%esc7 7 int_num return_type ax bx cx dx))))))) + +;;; +;;; The following Scheme function implements a file deletion +;;; capability. DOS-DELETE is called with an MS-DOS filename +;;; specifier which may NOT contain wildcard characters. The file +;;; specification can conatin drive and path specifications. An +;;; integer is returned indicating if the result was successful or not. +;;; A successful call will return 0, anything else indicates an error. +;;; For example: +;;; +;;; (DOS-DELETE "temp.exe") +;;; + +(define dos-delete + (lambda (filespec) + (if (string? filespec) + (if (file-exists? filespec) + (%esc2 10 filespec) + (error "DOS-DELETE: File does not exist!")) + (error "DOS-DELETE: Must specify a string!")))) + +;;; +;;; The following Scheme function implements a capability to copy +;;; DOS files. DOS-FILE-COPY is called with two MS-DOS filename +;;; specifiers. The first file must exist in the current directory, +;;; the second will be over written over if it does exist or created +;;; if it doesn't. The file specifications may NOT contain wildcard +;;; characters. The source file can contain a path specification. +;;; A drive designator may be specified as the destination +;;; but the destination may not be blank. If just a drive designation +;;; is entered then the source file name is appended to the destination. +;;; An integer is returned indicating if the call was successful or not. +;;; A zero indicates a successfull call, anything else indicates an error. +;;; For example: +;;; +;;; (DOS-FILE-COPY "temp.exe" "temp.xxx") +;;; +;;; Remember that Scheme requires the backslash character "\" to be +;;; escaped, so you must specify two "\\"'s in a character string if +;;; you want to see one "\". + +;;; compare-spec will return a number that is the first occurence of +;;; either a backslash or a colon that is not part of the file name. + +(define compare-spec + (lambda (len filespec) + (if (and (>? len 0) + (not (char-ci=? (string-ref filespec (-1+ len)) #\\)) + (not (char-ci=? (string-ref filespec (-1+ len)) #\:))) + (compare-spec (-1+ len) filespec) + len))) + +;;; strip-path will take a filespec as input and return just the file +;;; name without the path specification. + +(define strip-path + (lambda (filespec) + (substring filespec (compare-spec (string-length filespec) filespec) + (string-length filespec)))) + +(define dos-file-copy + (lambda (filespec1 filespec2) + (if (and (string? filespec1) (string? filespec2)) + (if (file-exists? filespec1) + (begin + +; if filespec2 is two characters where the second character is a colon +; and the first is a letter between A and J then append the filespec1 + + (if (and (equal? (string-length filespec2) 2) + (equal? (string-ref filespec2 1) #\:) + (char-ci>=? (string-ref filespec2 0) #\a) + (char-ci<=? (string-ref filespec2 0) #\j)) + +; now if filespec1 contains a pathname then only append the file name +; portion + + (set! filespec2 (string-append filespec2 + (strip-path filespec1)))) + + (%esc3 11 filespec1 filespec2)) + (error "DOS-FILE-COPY: File does not exist!")) + (error "DOS-FILE-COPY: Must specify a string!")))) + +;;; +;;; The following Scheme function implements a capability to rename +;;; files in the current directory. DOS-RENAME is called with two +;;; MS-DOS filename specifiers. The first must exist and the second +;;; cannot exist. The filename specifiers may NOT contain wildcard +;;; characters. The first file name can include drive and path +;;; specifications, the second cannot. An integer is returned +;;; indicating if the call was successful or not. For example: +;;; +;;; (DOS-RENAME "temp.exe" "temp.xxx") +;;; +;;; Remember that Scheme requires the backslash character "\" to be +;;; escaped, so you must specify two "\\"'s in a character string if +;;; you want to see one "\". + +;;; get-dir will change directories and if neccessary drives and +;;; return the previous path specification. + +(define get-dir + (lambda (filespec p-len) + (let ((old-drive '()) + (old-dir '()) + (path-spec (substring filespec 0 p-len ))) + +;;; p-len will be zero if there is no path or drive specification +;;; first use dos-chdir to change directories and then if necessary +;;; change drives + (when (<>? p-len 0) + (set! old-drive (substring (dos-chdir " ") 0 2)) + (if (and (>? p-len 1) + (equal? (string-ref path-spec 1) #\:)) + (dos-change-drive (substring path-spec 0 2))) + (if (and (>? p-len 1) + (equal? (string-ref path-spec (-1+ p-len)) #\\) + (not (equal? (string-ref path-spec (- p-len 2)) + #\:))) + (string-set! path-spec (-1+ p-len) #\ )) + (set! old-dir (dos-chdir path-spec))) + (list old-dir old-drive)))) + +;;; reset-dir will change back to the original drive and path +;;; specification, if necessary. + +(define reset-dir + (lambda (old-specs) + (when (not (equal? old-specs '(() ()) )) + (dos-chdir (car old-specs)) + (dos-change-drive (cadr old-specs)) + ))) + +(define dos-rename + (lambda (filespec1 filespec2) + + (if (and (string? filespec1) (string? filespec2)) + (if (file-exists? filespec1) + (let ((path-spec (get-dir filespec1 + (compare-spec (string-length filespec1) + filespec1))) + (return 0)) + ; if there is a drive or path to change to that has been done. + ; now check if the destination file exists + (if (not (file-exists? filespec2)) + (set! return (%esc3 12 (strip-path filespec1) filespec2)) + (error "DOS-RENAME: Destination file exists!")) + (reset-dir path-spec) + return) + (error "DOS-RENAME: Source file does not exist!")) + (error "DOS-RENAME: Must specify a string!")))) + +;;; +;;; The following Scheme function implements a file size capability +;;; DOS-FILE-SIZE is called with an MS-DOS filename specifier +;;; which may NOT contain wildcard characters, and returns +;;; an integer indicating the size of the file. For example: +;;; +;;; (DOS-FILE-SIZE "temp.exe") +;;; + +(define dos-file-size + (lambda (filespec) + (if (string? filespec) + (if (file-exists? filespec) + (%esc2 15 filespec) + (error "DOS-FILE-SIZE: File does not exist!")) + (error "DOS-FILE-SIZE: Must specify a string!")))) + +;;; +;;; The following Scheme function implements a capability to change +;;; the current directory. DOS-CHDIR is called with a string +;;; containing the directory which will become the current directory. +;;; A string is returned which contains the previous directory. +;;; For example: +;;; +;;; (DOS-CHDIR "a:\\source") +;;; +;;; Remember that Scheme requires the backslash character "\" to be +;;; escaped, so you must specify two "\\"'s in a character string if +;;; you want to see one "\". +;;; + +(define dos-chdir + (lambda directory + (if (null? directory) + (%esc2 16 "") + ;else + (if (string? (car directory)) + (%esc2 16 (car directory)) + (error "DOS-CHDIR: Argument must be a string!"))))) +; +; I personally like the following better, but above will ship for +; compatibility sake. +; +;(define dos-chdir +; (lambda dir +; (if (not (null? dir)) +; (if (string? (car dir)) +; (let* ((old-dir (%esc2 16 (car dir))) ; change directory +; (new-dir (%esc2 16 ""))) ; get new directory +; (if (string-ci=? old-dir new-dir) ; if new = old? +; '() ; return failure +; old-dir)) ; else return old dir +; (error "DOS-CHDIR: Argument must be a string")) +; ;else +; (%esc2 16 "")))) + +;;; +;;; The following Scheme function implements a capability to change +;;; the current drive. DOS-CHANGE-DRIVE is called with a string +;;; containing the drive which is to become the current drive. +;;; #!TRUE is returned if the call was successful or not. +;;; For example: +;;; +;;; (DOS-CHANGE-DRIVE "a:") +;;; + +(define dos-change-drive + (lambda (filespec) + (if (string? filespec) + (%esc2 17 filespec) + (error "DOS-CHANGE-DRIVE: Must specify a string!")))) + +) + \ No newline at end of file diff --git a/newpcs/pfunarg.s b/newpcs/pfunarg.s new file mode 100644 index 0000000..0d44ead --- /dev/null +++ b/newpcs/pfunarg.s @@ -0,0 +1,206 @@ + +; -*- Mode: Lisp -*- Filename: pfunarg.s + +; Last Revision: 12-Nov-85 1100ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; "Funarg" Backups for PCS Primitives ; +; ; +; NOTE: ; +; ; +; Most of these routines are defined in terms of primitive ; +; operations with the same name. Thus, they must be compiled ; +; with PCS-INTEGRATE-PRIMITIVES set true. Also, be sure not to ; +; use DEFREC!, LETREC, REC, etc., incorrectly. ; +; ; +; LAST UPDATE: ; +; 4/13/87 TC - Funarg handler for make-string ; +;--------------------------------------------------------------------------; + + +(define * ; * + (lambda args ; for funarg use, don't use DEFREC! + (cond ((null? args) + 1) + (t (do ((a (car args) (* a (car x))) + (x (cdr args) (cdr x))) + ((null? x) a)))))) + + +(define + ; + + (lambda args ; for funarg use, don't use DEFREC! + (cond ((null? args) + 0) + (t (do ((a (car args) (+ a (car x))) + (x (cdr args) (cdr x))) + ((null? x) a)))))) + + +(define - ; - + (lambda args ; for funarg use, don't use DEFREC! + (cond ((null? args) + 0) + ((null? (cdr args)) + (- (car args))) + (t (do ((a (car args) (- a (car x))) + (x (cdr args) (cdr x))) + ((null? x) a)))))) + + +(define / ; / + (lambda args ; for funarg use, don't use DEFREC! + (cond ((null? args) + 1) + ((null? (cdr args)) + (/ 1 (car args))) + (t (do ((a (car args) (/ a (car x))) + (x (cdr args) (cdr x))) + ((null? x) a)))))) + + +(define append ; APPEND + (letrec ; for funarg use + ((append* + (lambda (args) + (cond ((null? args) + '()) + ((null? (cdr args)) + (car args)) + ((null? (cddr args)) + (%append (car args)(cadr args))) + (else + (%append (car args) (append* (cdr args)))))))) + (lambda args + (append* args)))) + + +(define append! ; APPEND! + (letrec ; for funarg use + ((append!* ; don't use DEFREC! + (lambda (args) + (cond ((null? args) + '()) + ((null? (cdr args)) + (car args)) + ((null? (cddr args)) + (append! (car args) (cadr args))) + (else + (append! (car args) (append!* (cdr args)))))))) + (lambda args + (append!* args)))) + +(define char-ready? ; CHAR-READY? + (lambda args ; for funarg uses + (char-ready? (car args)))) ; don't define with defrec! + + +(define display ; DISPLAY + (lambda (exp . rest) ; for funarg uses + (display exp ; don't define with defrec! + (car rest)))) + + +(define list ; LIST + (lambda x x)) ; (for funarg use) + + +(define list* ; LIST* + (lambda x ; (for funarg use) + (let loop ((x x)) + (cond ((atom? x) x) + ((atom? (cdr x)) (car x)) + (else (cons (car x) (loop (cdr x)))))))) + + +(define make-vector ; MAKE-VECTOR + (lambda (size . rest) ; for funarg use, don't use DEFREC! + (let ((v (make-vector size))) + (when rest + (vector-fill! v (car rest))) + v))) + +(define make-string ; MAKE-STRING + (lambda (size . rest) ; for funarg use, don't use DEFREC! + (make-string size ; don't define with defrec! + (car rest)))) + + +(define max ; MAX + (lambda args ; for funarg use, don't use DEFREC! + (if (null? args) + 0 + (do ((a (car args) (max a (car x))) + (x (cdr args) (cdr x))) + ((null? x) a))))) + + +(define min ; MIN + (lambda args ; for funarg use, don't use DEFREC! + (if (null? args) + 0 + (do ((a (car args) (min a (car x))) + (x (cdr args) (cdr x))) + ((null? x) a))))) + + +(define newline ; NEWLINE + (lambda args ; for funarg uses + (newline (car args)))) ; don't define with defrec! + + +(define prin1 ; PRIN1 + (lambda (exp . rest) ; for funarg uses + (prin1 exp (car rest)))) ; don't define with defrec! + + +(define princ ; PRINC + (lambda (exp . rest) ; for funarg uses + (princ exp (car rest)))) ; don't define with defrec! + + +(define print ; PRINT + (lambda (exp . rest) ; for funarg uses + (print exp (car rest)))) ; don't define with defrec! + + +(define read-line ; READ-LINE + (lambda args ; for funarg uses + (read-line (car args)))) ; don't define with defrec! + + +(define read-atom ; READ-ATOM + (lambda args ; for funarg uses + (read-atom (car args)))) ; don't define with defrec! + + +(define read-char ; READ-CHAR + (lambda args ; for funarg uses + (read-char (car args)))) ; don't define with defrec! + + ; STRING-APPEND +;; STRING-APPEND should be moved here from PCHREQ.S +;; (for funarg definition) for consistency + +(define vector ; VECTOR + (lambda L + (list->vector L))) + + +(define write ; WRITE + (lambda (exp . rest) ; for funarg uses + (write exp (car rest)))) ; don't define with defrec! + +(define write-char ; WRITE-CHAR + (lambda (exp . rest) ; for funarg uses + (write-char exp (car rest)))) ; don't define with defrec + +(define %xesc ; %XESC (XLI) + (lambda (length name . rest) + (%execute (compile `(%xesc ,length ,name ,@rest))))) + \ No newline at end of file diff --git a/newpcs/pgencode.s b/newpcs/pgencode.s new file mode 100644 index 0000000..256d49f --- /dev/null +++ b/newpcs/pgencode.s @@ -0,0 +1,790 @@ + +; -*- Mode: Lisp -*- Filename: pgencode.s + +; Last Revision: 1-Oct-85 1630ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Code Generation ; +; ; +;--------------------------------------------------------------------------; +; +; Note: The current implementation never changes REG-BASE, so the +; registers may be sparsely used. Consider using fewer registers +; and implementing a wrap-around algorithm. +; +; Note: There is currently no check to ensure that DEST never exceeds +; MAX-REGNUM. Somebody ought to do something about that! +; (Implementing wrap-around would fix this, too.) +; +;--------------------------------------------------------------------------; + +(define pcs-gencode + (lambda (exp) + (letrec +;------! + ((debug-mode pcs-debug-mode) + + (max-regnum 62) ; highest available register number + ; r0 reserved for '() + ; r63 used by ppeep + (compiled-lambda-list '()) ; code for previously compiled closures + + (gen-code + (lambda (entry-name ; label for the code block + body ; expression to be compiled + bvl ; bound variable list + lex-level ; lambda nesting level + senv ; stack component of the lexical environment + henv ; heap component of the lexical environment + cenv) ; compile-time component of the lex env + (letrec +;--------------! + ( + (code '()) ; list of generated instructions and labels + (tos -1) ; stack level (size of current frame) + (reg-base -1) ; stack offset equivalent to register 0 + (last-label '()) ; last code entry label referenced + + (gen + (lambda (x dest tr?) + (cond ((atom? (car x)) + (case (car x) + (quote (gen-quote x dest tr?)) + (T (gen-id x dest tr?)) + (lambda (gen-closure x dest tr?)) + (if (gen-if x dest tr?)) + (set! (gen-set! x dest tr?)) + (%call/cc (gen-ccc x dest tr?)) + (begin (gen-begin (cdr x) dest tr?)) + (%apply (gen-apply x dest tr?)) + (letrec (gen-letrec x dest tr?)) + (else (gen-primitive x dest tr?)))) + ((eq? (caar x) 'LAMBDA) + (gen-let x dest tr?)) + (else + (gen-application x dest tr?))))) + + (gen-quote + (lambda (x dest tr?) + (emit-load dest + (if (null? (cadr x)) 0 x)) ; use R0 for '() + (continue dest tr?))) + + (gen-id + (lambda (id dest tr?) + (let ((name (id-name id)) + (info (assq id senv))) + (if info + (let ((dlevel (- lex-level (cddr info))) + (offset (cadr info))) + (if (and (zero? dlevel) ( > offset tos)) + (emit-load dest (- offset reg-base) name) + (emit-load dest `(STACK ,offset ,dlevel) name))) + (emit-load dest (list 'HEAP name))) + (continue dest tr?)))) + + (gen-set! + (lambda (x dest tr?) + (let* ((id (cadr x)) + (value (caddr x)) + (name (id-name id)) + (info (assq id senv))) + (gen value dest #!false) + (if info + (let ((dlevel (- lex-level (cddr info))) + (offset (cadr info))) + (if (and (zero? dlevel) ( > offset tos)) + (emit-load (- offset reg-base) dest (cons 'SET name)) + (emit 'STORE `(STACK ,offset ,dlevel) dest name))) + (emit 'STORE (list 'HEAP name) dest)) + (continue dest tr?)))) + + (gen-closure + (lambda (x dest tr?) + (let ((label (lambda-label x)) + (bvl (lambda-bvl x))) + (gen-code label + (lambda-body x) + bvl + (add1 lex-level) + senv + henv + cenv) + (when (or debug-mode (lambda-closed? x)) + (emit-load dest ; set up closure name + (if (null? (lambda-debug x)) + 0 ; use R0 for '() + (list 'QUOTE (lambda-debug x)))) + (emit 'CLOSE dest + dest + (list label (lambda-nargs x))) + (set! last-label label) + (continue dest tr?))))) + + (gen-if + (lambda (x dest tr?) + (let ((pred (if-pred x)) + (then (if-then x)) + (else (if-else x))) + (gen pred dest #!false) + (restore-regs dest) + (let* ((tos0 tos) + (out (gensym 'I))) + (cond ; (if a b '()) + ((equal? else ''()) + (emit-live dest) + (emit 'JUMP out 'NULL? dest) + (gen then dest tr?) + (restore-tos tos0 tr?) + (emit-label out) + (continue dest tr?) + ) ; (if a '() c) + ((equal? then ''()) + (emit 'NOT dest dest) + (emit-live dest) + (emit 'JUMP out 'NULL? dest) + (gen else dest tr?) + (restore-tos tos0 tr?) + (emit-label out) + (continue dest tr?) + ) ; (if a a c) + ((or (eq? pred then) + (and (memq (car pred) ; no side effects? + '(%%get-global%% + %%get-scoops%% + %%get-fluid%%)) + (equal? pred then))) + (emit-live dest) + (emit 'JUMP out 'T? dest) + (gen else dest tr?) + (restore-tos tos0 tr?) + (emit-label out) + (continue dest tr?) + ) ; (if a b c) + (else + (let ((lelse (gensym 'L))) + (emit-live dest) + (emit 'JUMP lelse 'NULL? dest) + (gen then dest tr?) + (restore-tos tos0 tr?) + (when (not tr?) + (emit-live dest) + (emit-jump out)) + (emit-label lelse) + (gen else dest tr?) + (restore-tos tos0 tr?) + (when (not tr?) + (emit-label out))))) + )))) + + (gen-ccc + (lambda (x dest tr?) + (let* ((fun (cadr x)) + (info (assq fun cenv))) ; CENV = () in debug mode + (if info + (let* ((label (cadr info)) ; open call + (delta-level (- lex-level + (caddr info))) + (delta-heap (- (length henv) + (length (cadddr info))))) + (set! last-label label) + (restore-regs dest) + (if (and tr? ( >= delta-level 0)) + (emit 'CALL + `(OPEN-TR ,label ,delta-level ,delta-heap) + 'CC) + (begin + (save-regs dest) + (emit 'CALL + `(OPEN ,label ,delta-level ,delta-heap) + 'CC) + (emit-copy dest 1) + (continue dest tr?)))) + (begin ; closed call + (gen fun dest #!false) + (restore-regs dest) + (if tr? + (emit 'CALL 'CLOSED-TR 'CC dest) + (begin + (save-regs dest) + (emit 'CALL 'CLOSED 'CC dest) + (emit-copy dest 1)))))))) + + (gen-begin + (lambda (x dest tr?) + (if (null? (cdr x)) + (gen (car x) dest tr?) + (begin + (gen (car x) dest #!false) + (gen-begin (cdr x) dest tr?))))) + + (gen-apply + (lambda (x dest tr?) + (let ((fun (cadr x)) + (arg (caddr x)) + (dest1 (add1 dest))) + (gen arg dest #!false) + (gen fun dest1 #!false) + (restore-regs dest) + (if tr? + (emit 'CALL 'CLOSED-APPLY-TR dest1 dest) + (begin + (save-regs dest) + (emit 'CALL 'CLOSED-APPLY dest1 dest) + (emit-copy dest 1)))))) + + (gen-let + (lambda (x dest tr?) + (let ((fun (car x)) + (args (cdr x))) + (gen-args args dest) + (restore-regs dest) + (let ((save-henv henv) + (save-senv senv) + (save-cenv cenv)) + (set! henv (cons '() henv)) + (let ((newdest (extend-bvl (lambda-bvl fun) dest))) + (gen (lambda-body fun) newdest tr?) + (when (not tr?) + (restore-regs newdest) + (drop dest) + (drop-env (- (length henv) ; normally 1 or 0 + (length save-henv))) + (emit-copy dest newdest)) + (set! henv save-henv) + (set! senv save-senv) + (set! cenv save-cenv)))))) + + + ;; + ;; LETREC pairs must be handled VERY carefully! We pass over them three + ;; times in order to get CENV, SENV, and (especially) HENV correct when + ;; referenced from within the pair expressions. + ;; + ;; Pass 1 - Determine which runtime variables must be heap allocated + ;; and reserve space for them on the heap-allocated stack. + ;; When done, HENV and SENV reflect the proper lexical + ;; environment for generating the code for the body AND the + ;; pairs themselves. + ;; + ;; Pass 2 - Add all compile-time only variables and "well-behaved" + ;; runtime variables to CENV. Note that CENV entries include + ;; the HENV in effect at the time of CLOSURE, which is AFTER all + ;; pair IDs have been allocated homes (in the first pass). + ;; + ;; Pass 3 - Generate code to assign pair expression values to pair IDs. + ;; Note that Passes 1 and 3 must have exactly the same behavior + ;; with respect to maintaining DEST. Thus, they have the same + ;; general structure. + + (gen-letrec + (lambda (x dest tr?) + (let ((save-henv henv) + (save-senv senv) + (save-cenv cenv)) + (set! henv (cons '() henv)) ; add a rib + (let ((newdest (gen-pairs (letrec-pairs x) dest)) + (body (letrec-body x))) + (gen body newdest tr?) + (when (not tr?) + (restore-regs newdest) + (drop dest) + (drop-env (- (length henv) ; normally 1 or 0 + (length save-henv))) + (emit-copy dest newdest)) + (set! henv save-henv) + (set! senv save-senv) + (set! cenv save-cenv))))) + + (gen-pairs + (lambda (pairs dest) + (gen-pairs-1 pairs dest) + (when (not debug-mode) + (gen-pairs-2 pairs)) + (gen-pairs-3 pairs dest))) + + (gen-pairs-1 + (lambda (pairs dest) + (if (null? pairs) + (if (null? (car henv)) + (set! henv (cdr henv)) + (begin + (set-car! henv (reverse! (car henv))) + (emit 'PUSH-ENV (car henv)))) + (let ((id (caar pairs)) + (exp (cadar pairs))) + (gen-pairs-1 + (cdr pairs) + (if (or debug-mode (id-rtv? id)) + (if (or debug-mode (id-heap? id)) + (begin ; heap-alloc lex var + (set-car! henv + (cons (id-name id) (car henv))) + dest) + (begin ; stack/reg-alloc lex var + (set! senv + (cons (cons id + (cons (+ reg-base dest) + lex-level)) + senv)) + (add1 dest))) ; reserve a register + dest)))))) + + + (gen-pairs-2 + (lambda (pairs) + (when pairs ; not called in debug mode + (let ((id (caar pairs)) + (exp (cadar pairs))) + (when (or (not (id-rtv? id)) + (and (not (id-set!? id)) + (eq? (car exp) 'lambda) + (not (negative? (lambda-nargs exp))))) + (set! cenv + (cons (list id (lambda-label exp) + (add1 lex-level) henv) + cenv)))) + (gen-pairs-2 (cdr pairs))))) + + (gen-pairs-3 + (lambda (pairs dest) + (if (null? pairs) + dest + (let ((id (caar pairs)) + (exp (cadar pairs))) + (gen exp dest #!false) + (restore-regs dest) + (gen-pairs-3 + (cdr pairs) + (if (or debug-mode (id-rtv? id)) + (if (or debug-mode (id-heap? id)) + (begin + (when (not (equal? exp '(quote ()))) + (emit 'STORE (list 'HEAP (id-name id)) + dest)) + dest) + (add1 dest)) + dest)))))) + + ;; Bound variable lists are similar to LETREC pairs, but much easier to + ;; deal with, since they are always runtime variables. Thus, EXTEND-BVL + ;; is a simplified combination of GEN-PAIRS-1 (setting up HENV and SENV) + ;; and GEN-PAIRS-3 (emitting PUSH-ENV instructions when needed). + + (extend-bvl + (lambda (bvl dest) + (extend-bvl-1 bvl dest) + (extend-bvl-2 bvl dest))) + + (extend-bvl-1 + (lambda (bvl dest) + (if (null? bvl) + (if (and (not debug-mode) + (null? (car henv))) + (set! henv (cdr henv)) ; null env frame + (begin + (set-car! henv (reverse! (car henv))) + (emit 'PUSH-ENV (car henv)))) + (let ((id (car bvl))) + (if (or debug-mode (id-heap? id)) + (set-car! henv (cons (id-name id) (car henv))) + (set! senv + (cons (cons id + (cons (+ reg-base dest) + lex-level)) + senv))) + (extend-bvl-1 (cdr bvl) (add1 dest)))))) + + (extend-bvl-2 + (lambda (bvl dest) + (if (null? bvl) + dest + (let ((id (car bvl))) + (when (or debug-mode (id-heap? id)) + (emit 'STORE (list 'HEAP (id-name id)) dest)) + (extend-bvl-2 (cdr bvl) (add1 dest)))))) + + (gen-application + (lambda (x dest tr?) + (let ((fun (car x))) + (let ((nargs (length (cdr x)))) + (when (not (zero? nargs)) + (gen-args (cdr x) dest)) + (let ((info (assq fun cenv))) ; CENV = () in debug mode + (if info + ;; open call + (let* ((label (cadr info)) + (delta-level (- lex-level + (caddr info))) + (delta-heap (- (length henv) + (length (cadddr info))))) + (when (not (= nargs (lambda-nargs (id-init fun)))) + (syntax-error "Wrong number of arguments in call" + (id-name fun))) + (set! last-label label) + (restore-regs dest) + (if (and tr? ; tail recursive + ( >= delta-level 0)) ; frame not needed + (begin + (move-regs dest 1 nargs) + (if (zero? delta-level) + (begin + (drop-all) + (drop-env delta-heap) + (emit-live nargs) + (emit-jump label)) + (emit 'CALL + `(OPEN-TR ,label ,delta-level + ,delta-heap) + (list nargs)))) + (begin + (save-regs dest) + (move-regs dest 1 nargs) + (emit 'CALL + `(OPEN ,label ,delta-level ,delta-heap) + (list nargs)) + (emit-copy dest 1) + (continue dest tr?)))) + ;; closed call + (let ((funreg (+ dest nargs)) ; compute function here + (nargs1 (+ nargs 1))) ; then move it here + ;; must compute function before moving regs down + (gen fun funreg #!false) + (restore-regs dest) + (if tr? + (begin + (move-regs dest 1 nargs1) + (emit 'CALL + 'CLOSED-TR (list nargs) nargs1)) + (begin + (save-regs dest) + (move-regs dest 1 nargs1) + (emit 'CALL + `CLOSED (list nargs) nargs1) + (emit-copy dest 1)))))))))) + + (out-of-registers! + (lambda () + (error " *** Compiler ran out of registers ***"))) + + (gen-args + (lambda (args dest) + (when args + (when (> dest max-regnum) + (out-of-registers!)) + (gen (car args) dest #!false) + (gen-args (cdr args)(add1 dest))))) + + (gen-primitive + (lambda (x dest tr?) + (let ((primop (car x))) + ;; (when (null? primop) + ;; (set! **null-primop** x) + ;; (writeln "++ Null primop found, saved in **NULL-PRIMOP**")) + (cond (( >= (+ dest (length (cdr x))) max-regnum) + (out-of-registers!)) + ((memq primop '(%%get-global%% %%set-global%% + %%get-scoops%% %%set-scoops%% + %%def-global%% %%get-fluid%% + %%set-fluid%% %%bind-fluid%% + %%unbind-fluid%%)) + (case primop + (%%get-global%% (gen-global-ref x dest tr? 'HEAP)) + (%%set-global%% (gen-global-set x dest tr? 'HEAP)) + (%%get-scoops%% (gen-global-ref x dest tr? 'GLOBAL)) + (%%set-scoops%% (gen-global-set x dest tr? 'GLOBAL)) + (%%def-global%% (gen-global-def x dest tr?)) + (%%get-fluid%% (gen-fluid-ref x dest tr?)) + (%%set-fluid%% (gen-fluid-set x dest tr?)) + (%%bind-fluid%% (gen-fluid-bind x dest tr?)) + (else (gen-fluid-unbind x dest tr?)))) + ((memq primop '(%xesc)) ;variable-length instructions + (let* ((inst-length (cadr x)) + (src-regs (gen-prim-args (cddr x) dest)) + (newdest (if (null? src-regs) + dest + (car src-regs))) + (instr `(,primop ,newdest ,inst-length ,@src-regs))) + (restore-regs dest) + (emit* instr) + (emit-copy dest newdest) + (continue dest tr?))) + ((and (memq primop '(+ - * / )) + (eq? (car (caddr x)) 'quote) + (integer? (cadr (caddr x))) + (< (abs (cadr (caddr x))) 128)) + (gen (cadr x) dest #!false) + (restore-regs dest) + (emit (cdr (assq primop + '((+ . %+imm)(- . %+imm) + (* . %*imm)(/ . %/imm)))) + dest + dest + (if (eq? primop '-) + `(quote ,(minus (cadr (caddr x)))) + (caddr x))) + (continue dest tr?)) + (else + (let* ((src-regs (gen-prim-args (cdr x) dest)) + (newdest (if (null? src-regs) + dest + (car src-regs))) + (instr (cons primop (cons newdest src-regs)))) + (restore-regs dest) + (emit* instr) + (emit-copy dest newdest) + (continue dest tr?))))))) + + (gen-prim-args + (lambda (args dest) + (cond ((null? args) ; 0 args + '()) + ((null? (cdr args)) ; 1 arg + (gen (car args) dest #!false) + (list dest)) + (else + (let ((arg1 (car args)) + (arg2 (cadr args)) + (dest1 (+ dest 1))) + (if (and (memq (car arg1) '(t quote %%get-global%%)) + (not (memq (car arg2) '(t quote %%get-global%%)))) + (begin + (gen arg2 dest #!false) + (gen arg1 dest1 #!false) ; lex var or constant + (cons dest1 + (cons dest + (gen-prim-args (cddr args)(+ dest 2))))) + (begin + (gen arg1 dest #!false) + (cons dest (gen-prim-args (cdr args) dest1))))))))) + + (gen-global-ref + (lambda (x dest tr? kind) + (emit-load dest (list kind (cadr (cadr x)))) + (continue dest tr?))) + + (gen-global-set + (lambda (x dest tr? kind) + (let ((symbol (cadr (cadr x))) + (value (caddr x))) + (gen value dest #!false) + (restore-regs dest) + (emit 'STORE (list kind symbol) dest) + (continue dest tr?)))) + + (gen-global-def + (lambda (x dest tr?) + (let ((symbol (cadr (cadr x))) + (value (caddr x))) + (gen value dest #!false) + (restore-regs dest) + (emit 'STORE (list 'GLOBAL-DEF symbol) dest) + (emit-load dest (cadr x)) + (continue dest tr?)))) + + (gen-fluid-ref + (lambda (x dest tr?) + (emit-load dest (list 'FLUID (cadr (cadr x)))) + (continue dest tr?))) + + (gen-fluid-set + (lambda (x dest tr?) + (let ((symbol (cadr (cadr x))) + (value (caddr x))) + (gen value dest #!false) + (restore-regs dest) + (emit 'STORE (list 'FLUID symbol) dest) + (continue dest tr?)))) + + (gen-fluid-bind + (lambda (x dest tr?) + (let ((symbol (cadr (cadr x))) + (value (caddr x))) + (gen value dest #!false) + (restore-regs dest) + (emit 'BIND-FLUID symbol dest) + (continue dest tr?)))) + + (gen-fluid-unbind + (lambda (x dest tr?) + (let ((symlist (cadr (cadr x)))) + (emit 'UNBIND-FLUIDS symlist) + (continue dest tr?)))) + + (continue + (lambda (dest tr?) + (when tr? ; tail recursive + (restore-regs dest) + (if (not (= dest 1)) + (emit-copy 1 dest)) + (emit 'CALL 'EXIT 1)))) + + (emit + (lambda instr + (set! code (cons instr code)))) + + (emit* + (lambda (instr) + (set! code (cons instr code)))) + + (emit-label + (lambda (tag) + (set! code (cons tag code)))) + + (emit-load + (lambda args + (set! code (cons (cons 'LOAD args) code)))) + + (emit-copy + (lambda (dest src) + (if (not (= dest src)) + (emit 'LOAD dest src)))) + (emit-live + (lambda (reg) + (emit 'LIVE + (if (zero? reg) + '() + (cons 1 reg))))) + + (emit-jump + (lambda (label) + (set! code (cons (cons 'JUMP (cons label '(ALWAYS))) + code)))) + + (emit-push + (lambda (reg) + (letrec + ((pushback + (lambda (reg prev curr) + (cond ((or (null? curr) ; start + (atom? (car curr)) ; label + (memq (caar curr) + '(POP PUSH DROP JUMP CALL)) + (and (not (atom? (cdar curr))) + (equal? reg (cadar curr)) + (or (not (eq? (caar curr) 'LOAD)) + (not (number? (caddr (car curr))))))) + (let ((tail (cons `(PUSH () ,reg) curr))) + (if (null? prev) + (set! code tail) + (set-cdr! prev tail)))) + ((and (eq? (caar curr) 'LOAD) + (= reg (cadar curr)) + (number? (caddr (car curr)))) + (pushback (caddr (car curr)) curr (cdr curr))) + (t (pushback reg curr (cdr curr))))))) + (begin + (pushback reg '() code) + (set! tos (add1 tos)) + (if (not (= tos (+ reg reg-base))) + (error " *** EMIT-PUSH error: " reg reg-base tos)))))) + + (emit-pop + (lambda (reg) + (if (not (= tos (+ reg reg-base))) + (error " *** EMIT-POP error: " reg reg-base tos)) + (emit 'POP reg) + (set! tos (sub1 tos)))) + + (save-regs + (lambda (reg) + (let ((reg-to-push (add1 (- tos reg-base)))) + (when ( < reg-to-push reg) + (emit-push reg-to-push) + (save-regs reg))))) + + (restore-regs + (lambda (reg) + (let ((reg-to-pop (- tos reg-base))) + (when ( >= reg-to-pop reg) + (emit-pop reg-to-pop) + (restore-regs reg))))) + + (restore-tos + (lambda (tos0 tr?) + (cond (tr? (set! tos tos0)) + (( > tos tos0) (emit-pop (- tos reg-base)) + (restore-tos tos0 tr?)) + (( < tos tos0) (emit-push (add1 (- tos reg-base))) + (restore-tos tos0 tr?))))) + + (drop-all + (lambda () + (let ((count (add1 tos))) + (when ( > count 0) + (emit 'DROP (list count)) + (set! tos -1))))) + + (drop ; drop down to and including REG + (lambda (reg) + (let* ((newtos (sub1 (+ reg reg-base))) + (count (- tos newtos))) + (when ( > count 0) + (emit 'DROP (list count)) + (set! tos newtos))))) + + (drop-env + (lambda (count) + (when (> count 0) + (emit 'DROP-ENV (list count))))) + + (move-regs + (lambda (from to count) + (if ( > from to) + (when ( > count 0) + (emit-copy to from) + (move-regs (add1 from)(add1 to)(sub1 count)))))) + +;--------------! + ) ;; body of gen-code + (let ((save-henv henv) + (save-senv senv) + (save-cenv cenv)) + (set! henv (cons '() henv)) ; add a rib + (let ((newdest (if (eq? entry-name '==main==) + 1 + (extend-bvl bvl 1)))) + (gen body newdest #!true) + (set! compiled-lambda-list + (cons (cons entry-name + (cons last-label (reverse! code))) + compiled-lambda-list)) + (set! henv save-henv) + (set! senv save-senv) + (set! cenv save-cenv) + ))))) + + (flatten + (lambda (cl) + (if (null? cl) + cl + (let* ((first (car cl)) + (label (car first)) + (last-label (cadr first)) + (oplist (cddr first)) + (rest (flat** last-label (cdr cl) '()))) + (cons label + (append! oplist + (flatten rest))))))) + + + (flat** + (lambda (label a b) + (cond ((null? label) a) + ((null? a) b) + ((eq? label (caar a)) (append! a b)) + (t (flat** label (cdr a) (cons (car a) b)))))) + +;------! + ) + (begin ;; body of pcs-gencode + (gen-code '==main== exp '() 1 '() '() '()) + (flatten compiled-lambda-list) + )))) + \ No newline at end of file diff --git a/newpcs/pgr.s b/newpcs/pgr.s new file mode 100644 index 0000000..9ddc9de --- /dev/null +++ b/newpcs/pgr.s @@ -0,0 +1,325 @@ + +; -*- Mode: Lisp -*- Filename: pgr.s + +; Last Revision: 7-May-87 + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985, 1986 (c) Texas Instruments ; +; ; +; David Bartley, Rusty Haddock ; +; ; +; MIT-Compatible Graphics Routines ; +; ; +;--------------------------------------------------------------------------; + +; Revisions: +; ds - added support for EGA modes 14, 16 +; rb 11/5/86 - modified for clipping +; rb 11/17/86 - graphics windows (they don't remember their state, though) +; mrm 5/07/87 - special handling for setting mode 3 +; ttc 3/11/88 - added support for VGA mode 18 + +(begin + (define clear-graphics) + (define clear-point) + (define draw-point) + (define draw-line-to) + (define is-point-on?) + (define position-pen) + (define set-pen-color!) + (define set-video-mode!) + (define get-video-mode) + (define draw-box-to) + (define draw-filled-box-to) + (define set-palette!) + (define point-color) ;new with 3.0 + (define set-clipping-rectangle!) ; " + (define graphics-window) ; " + (define get-pen-position) ; " + (define get-pen-color) ; " + (define current-graphics-window) ; " + (define reset-graphics) ;not documented + ) + +;;; A small note about the global variable PCS-MACHINE-TYPE: +;;; +;;; PCS-MACHINE-TYPE = 0 Machine type unknown +;;; = 1 TIPC -or- TI Bus-Pro in TIPC mode +;;; = 252 IBM-PC/AT +;;; = 253 IBM-PC/jr +;;; = 254 IBM-PC/XT +;;; = 255 IBM-PC -or- TI Bus-Pro in PC/AT mode +;;; +;;; No variable CURRENTLY indicates whether or not the PC has +;;; bit-mapped graphics capabilities. (This would be nice though.) + +(define *graphics-colors* ; *GRAPHICS-COLORS* + (if (=? pcs-machine-type 1) + '((black . 0) (blue . 1) (red . 2) (magenta . 3) + (green . 4) (cyan . 5) (yellow . 6) (white . 7)) + '((black . 0) (cyan . 1) (magenta . 2) (white . 3)))) ; IBM mode #4 + +(define *character-boxes* ; horiz x vert by graphics mode + '((TI 9 . 12) (4 8 . 8) (14 8 . 8) (16 8 . 14) (18 8 . 16))) + + +;;; extended MIT Graphics Procedures +;;; +;;; TI User coordinates: -360 <= X <= +359 +;;; -150 <= Y <= +149 +;;; IBM User coordinates: -160 <= X <= +159 For 320x200/4-color mode (#4) +;;; -100 <= Y <= +99 +;;; IBM User coordinates: -320 <= X <= +319 For 640x200/16-color mode (#14) +;;; -100 <= Y <= +99 +;;; IBM User coordinates: -320 <= X <= +319 For 640x350/16-color mode (#16) +;;; -175 <= Y <= +174 +;;; IBM User coordinates: -320 <= X <= +319 For 640x480/16-color mode (#18) +;;; -240 <= Y <= +239 +;;; +;;; for IBM, mode 4 values are the default. +;;; + +(let ((cur-x '()) ; X,Y should be in fixnum range, else get + (cur-y '()) ; "invalid operand" error when %GRAPHICS executes + (cur-w 'screen) ; use 'screen for screen, else have window here + ; note 'screen and 'console are *not* synonyms + (cur-color '()) + (max-x (if (=? pcs-machine-type 1) 719 319)) + (max-y (if (=? pcs-machine-type 1) 299 199)) + (mid-x (if (=? pcs-machine-type 1) 360 160)) + (mid-y (if (=? pcs-machine-type 1) 149 99)) + (min-x 0) + (min-y 0) + (num-clrs (if (=? pcs-machine-type 1) 8 4))) + + (begin + + (if (=? pcs-machine-type 1) + (set! clear-graphics ; CLEAR-GRAPHICS (TIPC) + (lambda () + (reset-graphics) + (if (not (eq? cur-w 'screen)) + (begin + (graphics-window cur-w) + (position-pen 0 0) + (%graphics 7 0 0 1024 1024 0 0)) ; clear window to black + (begin + (%graphics 0 0 0 0 0 0 0) ; Clear the graphics planes + (%graphics 0 3 0 0 0 0 0))) ; Enable both text & graphics planes + '())) + + (set! clear-graphics ; CLEAR-GRAPHICS (IBM) + (lambda () + (reset-graphics) + (if (not (eq? cur-w 'screen)) + (begin + (graphics-window cur-w) + (position-pen 0 0) + (%graphics 7 0 0 1024 1024 0 0)) ; clear window to black + (%graphics 0 (get-video-mode) + 0 0 0 0 0)) ; IBM graphics and text are on same + ; plane and will SCROLL together!!! + (%graphics 2 1 1 0 0 0 0) ; Ensure proper colors are used - CGA + '()))) + + (set! reset-graphics + (lambda () + (if (=? pcs-machine-type 1) + (begin ;TI + (set! max-x 719) + (set! max-y 299) + (set! mid-x 359) + (set! mid-y 149) + (set! min-x 0) + (set! min-y 0) + (set! cur-color 7) + (position-pen 0 0)) + (case (get-video-mode) ;IBM + (4 + (set! max-x 319) + (set! max-y 199) + (set! mid-x 160) + (set! mid-y 99) + (set! min-x 0) + (set! min-y 0) + (set! num-clrs 4) + (set! *graphics-colors* + '((black . 0) (cyan . 1) (magenta . 2) (white . 3))) + (set! cur-color (sub1 num-clrs)) + (position-pen 0 0)) + ((14 16 18) + (set! max-x 639) + (set! mid-x 320) + (set! min-x 0) + (set! min-y 0) + (set! num-clrs 16) + (set! *graphics-colors* + '((black . 0) (blue . 1) (green . 2) (cyan . 3) + (red . 4) (magenta . 5) (brown . 6) (white . 7) + (gray . 8) (light-blue . 9) + (light-green . 10) (light-cyan . 11) + (light-red . 12) (light-magenta . 13) + (yellow . 14) (intense-white . 15))) + (set! cur-color (sub1 num-clrs)) + (case (get-video-mode) + (14 + (set! max-y 199) + (set! mid-y 99)) + (16 + (set! max-y 349) + (set! mid-y 174)) + (18 + (set! max-y 479) + (set! mid-y 238))) + (position-pen 0 0)) + (else + '())) ; for other modes, do nothing + ))) + + (set! draw-point ; DRAW-POINT + (lambda (x y) + (%graphics 1 (+ x mid-x) (- mid-y y) cur-color 0 0 0) + '())) + + (set! clear-point ; CLEAR-POINT + (lambda (x y) + (%graphics 1 (+ x mid-x) (- mid-y y) 0 0 0 0) + '())) + + (set! is-point-on? ; IS-POINT-ON? + (lambda (x y) + (positive? (%graphics 4 (+ x mid-x) (- mid-y y) 0 0 0 0)))) + + (set! point-color ; POINT-COLOR + (lambda (x y) + (%graphics 4 (+ x mid-x) (- mid-y y) 0 0 0 0))) + + (set! position-pen ; POSITION-PEN + (lambda (x y) + (set! cur-x (+ x mid-x)) + (set! cur-y (- mid-y y)) + '())) + + (set! get-pen-position ; GET-PEN-POSITION + (lambda () + (cons (- cur-x mid-x) (- mid-y cur-y)))) + + (set! draw-line-to ; DRAW-LINE-TO + (lambda (x y) + (let ((old-x cur-x) + (old-y cur-y)) + (position-pen x y) + (%graphics 3 old-x old-y cur-x cur-y cur-color 0) + '()))) + + (set! set-pen-color! ; SET-PEN-COLOR! + (lambda (color) + (set! cur-color + (if (integer? color) + (remainder (abs color) num-clrs) + (let ((entry (assq color *graphics-colors*))) + (if entry + (remainder (abs (cdr entry)) num-clrs) + (-1+ num-clrs))))))) + + (set! get-pen-color ; GET-PEN-COLOR + (lambda () cur-color)) + + (set! set-video-mode! ; SET-VIDEO-MODE! + (lambda (mode) + (%graphics 0 mode 0 0 0 0 0) + (case pcs-machine-type + (1 ;TI mode - do nothing special + '()) + (else ;default to IBM + (case mode + (3 ;IBM CGA + (window-set-attribute! pcs-status-window + 'text-attributes #x70)) + ((14 16 18) ;IBM EGA or VGA + (window-set-attribute! pcs-status-window + 'text-attributes #x87))) + (set! cur-w 'screen) + (if (<> mode 3) + (reset-graphics)))) ;if you're switching modes in IBM, + ;it makes sense to do this too + '())) + + (set! get-video-mode ; GET-VIDEO-MODE + (lambda () + (%graphics 5 0 0 0 0 0 0))) + + (set! draw-box-to ; DRAW-BOX-TO + (lambda (x y) + (let ((old-x cur-x) + (old-y cur-y)) + (set! cur-x (+ x mid-x)) + (set! cur-y (- mid-y y)) + (%graphics 6 old-x old-y cur-x cur-y cur-color 0) + '()))) + + (set! draw-filled-box-to ; DRAW-FILLED-BOX-TO + (lambda (x y) + (let ((old-x cur-x) + (old-y cur-y)) + (set! cur-x (+ x mid-x)) + (set! cur-y (- mid-y y)) + (%graphics 7 old-x old-y cur-x cur-y cur-color 0) + '()))) + + (set! set-palette! ; SET-PALETTE! + (lambda (arg1 arg2) + (when (not (and (integer? arg1) + (integer? arg2))) + (%error-invalid-operand-list 'SET-PALETTE! arg1 arg2)) + (when (and (>=? pcs-machine-type #xFC) ; IBM + (=? arg1 1) + (=? (get-video-mode) 4)) + (set! *graphics-colors* + (if (odd? arg2) + '((black . 0)(cyan . 1)(magenta . 2)(white . 3)) + '((black . 0)(green . 1)(red . 2)(yellow . 3))))) + (%graphics 2 arg1 arg2 0 0 0 0) + '())) + + (set! set-clipping-rectangle! ; SET-CLIPPING-RECTANGLE! + (lambda (x1 y1 x2 y2) ;left, top, right, bottom + (%graphics 8 (min max-x (max min-x (+ x1 mid-x))) + (min max-y (max min-y (- mid-y y1))) + (max min-x (min max-x (+ x2 mid-x))) + (max min-y (min max-y (- mid-y y2))) 0 0) + '())) + + (set! current-graphics-window ; CURRENT-GRAPHICS-WINDOW + (lambda () cur-w)) + + (set! graphics-window ; GRAPHICS-WINDOW + (lambda (window) + (let ((w (if (eq? window 'screen) 'console window))) + (let ((size (window-get-size w)) + (pos (window-get-position w)) + (cbox (cdr (assv (cond ((= pcs-machine-type 1) 'TI) + ((>= pcs-machine-type #xFC) (get-video-mode)) + (else pcs-machine-type)) + *character-boxes*)))) + (if (null? cbox) (error "Current video mode is not a graphics mode." (get-video-mode))) + (let* ((left (* (cdr pos) (car cbox))) + (top (* (car pos) (cdr cbox))) + (right (sub1 (+ left (* (cdr size) (car cbox))))) + (bottom (sub1 (+ top (* (car size) (cdr cbox)))))) + (%graphics 8 left top right bottom 0 0) + (set! mid-x (quotient (+ left right) 2)) + (set! mid-y (quotient (+ top bottom) 2)) + (set! min-x left) + (set! min-y top) + (set! max-x right) + (set! max-y bottom) + (set! cur-w window) + (list (list (- min-x mid-x) (- mid-y min-y) + (- max-x mid-x) (- mid-y max-y)) + (list left top right bottom))))))) + + '#!false)) + \ No newline at end of file diff --git a/newpcs/pinspect.s b/newpcs/pinspect.s new file mode 100644 index 0000000..5678bfd --- /dev/null +++ b/newpcs/pinspect.s @@ -0,0 +1,368 @@ + +; -*- Mode: Lisp -*- Filename: pinspect.s + +; Last Revision: 12-Nov-85 1400ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; The Inspector and %PCS-EDIT-BINDING ; +; ; +;--------------------------------------------------------------------------; + + +(define %inspect ; %INSPECT + (lambda (cur-env) + (cond ((environment? cur-env) + (%inspector '() '() '() + cur-env + (%reify-stack (+ (%reify-stack -1) 6)) + 0)) + ((closure? cur-env) + (%inspect (procedure-environment cur-env))) + (else + (display "Invalid operand to INSPECT: ") + (display cur-env))))) + + +(define %inspector ; %inspector + (letrec + ((table + '((1 . "All") ; ctrl-A + (2 . "Backtrace calls") ; ctrl-B + (3 . "Current environment frame") ; ctrl-C + (4 . "Down to callee") ; ctrl-D + (5 . "Edit: ") ; ctrl-E + (7 . "Go") ; ctrl-G + (9 . "Inspect: ") ; ctrl-I + (12 . "List Procedure") ; ctrl-L + (13 . "Repeat Breakpoint Message") ; ctrl-M + (16 . "`Parent' environment frame") ; ctrl-P + (17 . "Quit") ; ctrl-Q + (18 . "Return with the value: ") ; ctrl-R + (19 . "`Son' environment frame") ; ctrl-S + (21 . "Up to caller") ; ctrl-U + (22 . "Value of: ") ; ctrl-V + (23 . "Where am I?") ; ctrl-W + (#\SPACE . "Value of: ") + (#\! . "Reinitialize INSPECT!") + (#\? . "?"))) + + (repl + (lambda () + (pcs-clear-registers) + (fresh-line) + (newline) + (display "[Inspect] ") + (flush-input) + (let* ((ch (read-char)) + (key (if (memv ch '(#\SPACE #\! #\?)) + ch + (char->integer ch))) + (entry (assv key table))) + (when entry + (display (cdr entry))) + (case key + (1 (all cur-env 0)(repl)) ; ctrl-A + (2 (newline)(where stk-index) ; ctrl-B + (backtrace stk-index)(repl)) + (3 (newline) ; ctrl-C + (current cur-env 0 #!true) + (repl)) + (4 (newline) ; ctrl-D + (down)(repl)) + (5 (let ((ans ; ctrl-E + (%pcs-edit-binding '() (read) cur-env))) + (when (string? ans)(display ans)) + (repl))) + ((7 18) ; ctrl-G, ctrl-R + (leave key)) + (12 (newline) ; ctrl-L + (pp (%reify-stack (+ stk-index 15))) + (repl)) + (13 (newline) ; ctrl-M + (display kind) + (when kind + (when msg (display msg)) + (newline) + (write irritant)) + (repl)) + (16 (newline) ; ctrl-P + (parent cur-env)(repl)) + (17 (reset)) ; ctrl-Q + (19 (newline) ; ctrl-S + (son)(repl)) + (21 (newline) ; ctrl-U + (up)(repl)) + ((22 #\SPACE) + (pp (eval (read) cur-env)) ; ctrl-V, SPACE + (repl)) + (23 (newline) ; ctrl-W + (where stk-index)(repl)) + (#\! (newline)(init)(repl)) ; ! + (#\? (newline) ; ? + (help)(repl)) + (else + (if (eqv? key 9) ; ctrl-I + (let ((env (eval (read) cur-env))) + (cond ((or (environment? env) + (closure? env) + (delayed-object? env)) + (set! (fluid %inspector-continuation) '()) + (%inspect env)) + (else + (display (integer->char 7)) ; beep + (display " ? Not an environment: ") + (write env))) + (repl)) + (begin + (display (integer->char 7)) ; beep + (display " ? Invalid response... Type `?' for help") + (repl)))))) + )) + + (All + (lambda (env depth) + (fresh-line) + (when (and env (not (eq? env user-global-environment))) + (current env depth #!true) + (all (environment-parent env) (+ depth 1))))) + + (Backtrace + (lambda (stk-index) + (let ((si (%reify-stack (+ stk-index 6)))) + (fresh-line) + (when (positive? si) + (display " called from ") + (display (%reify-stack (+ si 15))) + (backtrace si))))) + + (Current + (lambda (env depth verbose?) + (when verbose? + (display "Environment frame bindings at level ") + (display (+ depth (length son-stk))) + (cond ((eq? env user-initial-environment) + (display " (USER-INITIAL-ENVIRONMENT)")) + ((eq? env user-global-environment) + (display " (USER-GLOBAL-ENVIRONMENT)")))) + (when (or verbose? + (=? (%reify env -1) 12)) ; not a global environment + (let ((frame (environment-bindings env))) + (if (null? frame) + (begin + (newline) + (display " --no variables--")) + (let loop ((pairs frame)) + (when pairs + (newline) + (display " ") + (if (char-ready?) + (display "[aborted]") + (let ((val (cdar pairs))) + (display (caar pairs)) ; var + (display " ") + (tab27 (current-column)) + (cond ((pair? val) + (display "-- list --")) + ((vector? val) + (display "-- vector --")) + (else (write val))) + (loop (cdr pairs)))))) + ))))) + + (Down + (lambda () + (if (null? down-stk) + (display " ? Can't move Down") + (let ((si (car down-stk))) + (set! down-stk (cdr down-stk)) + (set! stk-index si) + (set! son-stk '()) + (set! cur-env (%reify-stack (+ si 9))) + (where si))))) + + (Leave + (lambda (key) + (cond ((not (zero? exit-code)) + (newline) + (display " ? Sorry, the program is not resumable") + (repl)) + ((eqv? key 7) ; ctrl-G + (newline) + '()) + ((memq msg '(BREAK-ENTRY BREAK-EXIT)) + ((fluid %*BREAK*continuation) (eval (read) cur-env))) + (else + (newline) + (display " ? Sorry, use `ctrl-R' only to return from BREAK") + (repl))))) + + (Parent + (lambda (env) + (let ((penv (environment-parent env))) + (if (null? penv) + (display " ? No parent exists") + (begin + (set! son-stk (cons env son-stk)) + (set! cur-env penv) + (current penv 0 #!true)))))) + + (Son + (lambda () + (if (null? son-stk) + (display " ? No son exists") + (begin + (set! cur-env (car son-stk)) + (set! son-stk (cdr son-stk)) + (current cur-env 0 #!true))))) + + (Up + (lambda () + (let ((si (%reify-stack (+ stk-index 6)))) + (if (positive? si) + (begin + (set! down-stk (cons stk-index down-stk)) + (set! son-stk '()) + (set! cur-env (%reify-stack (+ si 9))) + (set! stk-index si) + (where si)) + (display " ? Can't move Up"))))) + + (Where + (lambda (si) + (display "Stack frame for ") + (display (%reify-stack (+ si 15))) + (current cur-env 0 #!false) )) + + (tab27 + (lambda (cur) + (cond ((>? 24 cur) (display " ")(tab27 (+ cur 3))) + ((>? 27 cur) (display " ") (tab27 (+ cur 1))) + ((= 27 cur) cur) + (else (newline) (tab27 1))))) + + (init + (lambda () + (set! son-stk '()) + (set! down-stk '()) + (set! cur-env orig-env) + (set! stk-index orig-stk-index) )) + + (help + (lambda () + (mapc (lambda (x)(display x)) + '(" ? -- display this command summary" #\newline + " ! -- reinitialize INSPECT" #\newline + " ctrl-A -- display All environment frame bindings" #\newline + " ctrl-B -- display procedure call Backtrace" #\newline + " ctrl-C -- display Current environment frame bindings" #\newline + " ctrl-D -- move Down to callee's stack frame" #\newline + " ctrl-E -- Edit variable binding" #\newline + " ctrl-G -- Go (resume execution)" #\newline + " ctrl-I -- evaluate one expression and Inspect the result" + #\newline + " ctrl-L -- List current procedure" #\newline + " ctrl-M -- repeat the breakpoint Message" #\newline + " ctrl-P -- move to Parent environment's frame" #\newline + " ctrl-Q -- Quit (RESET to top level)" #\newline + " ctrl-R -- Return from BREAK with a value" #\newline + " ctrl-S -- move to Son environment's frame" #\newline + " ctrl-U -- move Up to caller's stack frame" #\newline + " ctrl-V -- eValuate one expression in current environment" + #\newline + " ctrl-W -- (Where) Display current stack frame" #\newline + "To enter `ctrl-A', press both `CTRL' and `A'." + )))) + + ;; data + + (down-stk '()) + (son-stk '()) + (orig-env '()) + (orig-stk-index '()) + (msg '()) + (kind '()) + (irritant '()) + (cur-env '()) + (stk-index '()) + (exit-code '()) + ) + (lambda (msg0 kind0 irritant0 cur-env0 stk-index0 exit-code0) + (if (and (fluid-bound? %inspector-continuation) + (not (null? (fluid %inspector-continuation)))) + ((fluid %inspector-continuation) '()) + (fluid-let ((%inspector-continuation '())) + (set! msg msg0) + (set! kind kind0) + (set! irritant irritant0) + (set! cur-env cur-env0) + (set! stk-index stk-index0) + (set! exit-code exit-code0) + (set! orig-env cur-env0) + (set! orig-stk-index stk-index0) + (init) + (call/cc + (lambda (k) + (set! (fluid %inspector-continuation) k))) + (repl))) + ))) + + + +;;; %PCS-EDIT-BINDING +;;; +;;; argument OBJ: () or value to be edited +;;; optional arg NAME: symbol +;;; optional arg ENV: environment for name +;;; +;;; When NAME and ENV are not supplied, %PCS-EDIT-BINDING calls the +;;; editor to edit OBJ. +;;; +;;; When NAME and ENV are supplied, %PCS-EDIT-BINDING calls the editor +;;; to create a new binding for the name in the environment. If OBJ is +;;; nil, the current binding of NAME in ENV is edited instead of OBJ. +;;; +;;; returns either (1) an error message string or +;;; (2) (LIST edited-value) + +(define %pcs-edit-binding + (letrec ((help + (lambda (obj name) + (if (closure? obj) + (let ((info (assq 'SOURCE (%reify obj 0)))) + (if (null? info) + "[No source found for compiled procedure.]" + (let ((new (edit (cdr info)))) + (if (and (pair? new) + (eq? (car new) 'LAMBDA)) + (let ((mode pcs-debug-mode)) + (set! pcs-debug-mode #!true) + (let ((value (eval new))) + (set! pcs-debug-mode mode) + (%reify! value 0 + (cons (cons 'SOURCE new) name)) + (list value))) + (list new))))) + (list (edit obj)))))) + (lambda (obj . rebind) + (if (null? rebind) + (help obj rebind) + (let ((name (car rebind)) + (env (cadr rebind))) + (if (and (symbol? name)(environment? env)) + (let ((value-list (help (or obj (cdr (%env-lu name env))) + name))) + (if (atom? value-list) + value + (let ((value (car value-list)) + (cell (%env-lu name env))) + (if (null? cell) + (%define name value env) + (set-cdr! cell value))))) + "[Invalid argument]")))))) + \ No newline at end of file diff --git a/newpcs/pio.s b/newpcs/pio.s new file mode 100644 index 0000000..2db1825 --- /dev/null +++ b/newpcs/pio.s @@ -0,0 +1,499 @@ + +; -*- Mode: Lisp -*- Filename: pio.s + +; Last Revision: 10-Feb-87 0800ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Standard SCHEME Input/Output Routines ; +; ; +; READ modified for R^3 quasi-quote - TC ; +; READ-STRING removed and coded in asm 2/10/87 - TC ; +; Random I/O included from David Stevens 2/10/87 - TC ; +; Fixed input-port? and output-port? 3/13/87 - TC ; +; Open-binary-input-file,open-binary-output-file 3/13/87 - TC ; +; compile, etc. removed and placed in PCOMP.S ; +; for building of compiler-less system 6/02/87 - TC ; +; LOAD is just defined in terms of FAST-LOAD ; +; for compilerless systems. Its real definition ; +; is in PCOMP.S. 6/15/87 - TC ; +; Set line-length=0 for OPEN-BINARY-OUTPUT-FILE 1/21/88 - RB ; +; ; +;--------------------------------------------------------------------------; + + +; The following definitions are used only at compile time for readability +; and understanding. They will not be written out to the .so file. +; See pboot.s and compile.all. + + (compile-time-alias %read-file-flag #b00000001) ; read flag + (compile-time-alias %write-file-flag #b00000011) ; write flag(s) + (compile-time-alias %window-flag #b00000100) ; window port + (compile-time-alias %open-file-flag #b00001000) ; open port + (compile-time-alias %binary-file-flag #b00100000) ; binary file + (compile-time-alias %string-flag #b01000000) ; string file + +(define call-with-input-file ; CALL-WITH-INPUT-FILE + (lambda (filename proc) + (let* ((port (open-input-file filename)) + (answer (proc port))) + (close-input-port port) + answer))) + + +(define call-with-output-file ; CALL-WITH-OUTPUT-FILE + (lambda (filename proc) + (let* ((port (open-output-file filename)) + (answer (proc port))) + (close-output-port port) + answer))) + + +(define current-column ; CURRENT-COLUMN + (lambda args + (+ 1 (%reify-port (car args) 1)))) + + +(define-integrable current-input-port ; CURRENT-INPUT-PORT + (lambda () + (fluid input-port))) + +(define-integrable current-output-port ; CURRENT-OUTPUT-PORT + (lambda () + (fluid output-port))) + +(define eof-object? ; EOF-OBJECT? + (lambda (obj) + (eqv? obj eof))) ; temporary ??? + + +;;; +;;; Compile functions are now in PCOMP.S, ; COMPILE +;;; which reflects compiler-only functions +;;; + + +(define fast-load ; FAST-LOAD + (lambda (file) + (letrec ((fasl + (lambda (name) + (let ((pgm (%%fasl name))) + (when (not (eof-object? pgm)) + (%execute pgm) + (fasl '() )))))) + (if (string? file) + (if (file-exists? file) + (begin + (fasl file) + 'ok) + (error "FAST-LOAD file does not exist" file)) + (%error-invalid-operand 'FAST-LOAD file))))) + +(if (unbound? load) + (define load fast-load)) ; LOAD + +(define file-exists? ; FILE-EXISTS? + (lambda (name) + (and (string? name) + (not (string-null? name)) + (call/cc + (fluid-lambda (*file-exists-open*) + (let ((port (%open-port name 'read))) + (if (port? port) + (begin + (close-input-port port) + #!true) + ;else + #!false))))))) + +(define flush-input ; FLUSH-INPUT + (lambda args + (let ((x '()) + (port (car args))) + (if (and (not (zero? (%logand (%reify-port port 11) %open-file-flag))) + (zero? (%logand (%reify-port port 11) %read-file-flag)) + (char-ready? port)) + (do ((x (read-char port) (read-char port)) ) + ((or (eq? x #\newline) + (eof-object? x) + (not (char-ready? port))))))))) + + + +(define fresh-line ; FRESH-LINE + (lambda p + (when p (set! p (car p))) + (when (positive? (%reify-port p 1)) + (newline p)))) + + +(define input-port? ; INPUT-PORT? + (lambda (p) + (and (port? p) + (let ((pflags (%reify-port p 11))) + (and (not (zero? (%logand %open-file-flag pflags))) + (zero? (%logand %read-file-flag pflags))))))) + +(define line-length ; LINE-LENGTH + (lambda args + (%reify-port (car args) 5))) + +(define open-input-file ; OPEN-INPUT-FILE + (lambda (name) (%open-port name 'read))) + +(define open-binary-input-file ; OPEN-BINARY-INPUT-FILE + (lambda (name) + (let ((port (%open-port name 'read))) + (%reify-port! + port + 11 + (%logior %binary-file-flag (%reify-port port 11))) + port))) + +(define open-output-file ; OPEN-OUTPUT-FILE + (lambda (name) (%open-port name 'write))) + +(define open-binary-output-file ; OPEN-BINARY-OUTPUT-FILE + (lambda (name) + (let ((port (%open-port name 'write))) + (%reify-port! + port + 11 + (%logior %binary-file-flag (%reify-port port 11))) + (set-line-length! 0 port) + port))) + +(define open-extend-file ; OPEN-EXTEND-FILE + (lambda (name) (%open-port name 'append))) + +(define close-input-port ; CLOSE-INPUT-PORT + (lambda (port) (%close-port port))) + +(define close-output-port ; CLOSE-OUTPUT-PORT + (lambda (port) (%close-port port))) + + +(define (open-input-string str) ; OPEN-INPUT-STRING + (if (string? str) + (let ((p (%make-window '()))) + (%reify! p 0 str) + (%reify-port! p 2 3) + (%reify-port! p 11 (%logior %string-flag (%reify-port p 11))) + p) + (%error-invalid-operand 'OPEN-INPUT-STRING str))) + + +(define output-port? ; OUTPUT-PORT? + (lambda (p) + (and (port? p) + (let ((pflags (%reify-port p 11))) + (and (not (zero? (%logand %open-file-flag pflags))) + (not (zero? (%logand %write-file-flag pflags)))))))) + +(define read ; READ + (letrec + ((rd-object + (lambda (port qq?) + (let ((item (read-atom port))) + (cond ((eof-object? item) item) + ((atom? item) item) + (else + (let ((item (car item))) + (case item + (|#(| (rd-vector-tail port qq?)) + ( |(| (rd-list-tail port qq?)) + ( |)| (error "Unexpected `)' encountered before `('")) + ( |.| (dot-warning)(rd-object port qq?)) + ( |`| (rd-mac port #!true item #!false)) + ( |'| (rd-mac port qq? item #!false)) + ((|[| |]| |{| |}|) + item) + (else (rd-mac port qq? item #!true))))))))) + (rd-mac + (lambda (port qq? item qq-op?) + (if (and (not qq?) qq-op?) + (error "Invalid outside of QUASIQUOTE expression:" item) + (let ((obj (rd-object port qq?))) + (if (eof-object? obj) + (eof-warning) + (list (cdr (assq item qq-ops)) obj)))))) + (rd-vector-tail + (lambda (port qq?) + (list->vector (rd-tail port qq? #!false '())))) + (rd-list-tail + (lambda (port qq?) + (rd-tail port qq? #!true '()))) + (rd-tail + (lambda (port qq? dot-ok? result) + (let ((item (read-atom port))) + (cond ((eof-object? item) + (eof-warning) + (reverse! result)) + ((atom? item) + (if (eq? item 'quasiquote) + (rd-tail port #!true dot-ok? (cons item result)) + ;else + (rd-tail port qq? dot-ok? (cons item result)))) + (else + (let ((item (car item))) + (case item + ( |)| (reverse! result)) + ( |.| (if (and dot-ok? (not (null? result))) + (rd-dotted-tail port qq? result) + (begin + (dot-warning) + (rd-tail port qq? dot-ok? result)))) + (else + (let ((obj (case item + (|#(| (rd-vector-tail port qq?)) + ( |(| (rd-list-tail port qq?)) + ( |`| (rd-mac port #!true item #!false)) + ( |'| (rd-mac port qq? item #!false)) + ((|[| |]| |{| |}|) + item) + (else (rd-mac port qq? item #!true))))) + (rd-tail port qq? dot-ok? (cons obj result))))))))))) + (rd-dotted-tail + (lambda (port qq? result) + (let ((tail (rd-tail port qq? #!false '()))) + (append! (reverse! result) + (cond ((and (pair? tail) + (null? (cdr tail))) + (car tail)) + (else + (dot-warning) + tail)))))) + (dot-warning + (lambda () + (newline) + (display "WARNING -- Invalid use of `.' encountered during READ") + (newline))) + (eof-warning + (lambda () + (newline) + (display "WARNING -- EOF encountered during READ") + (newline) + eof)) + (qq-ops + '((|'| . QUOTE) + (|`| . QUASIQUOTE) + (|,| . UNQUOTE) + (|,@| . UNQUOTE-SPLICING) + (|,.| . UNQUOTE-SPLICING!)))) + (lambda args + (let ((port (car args))) + (rd-object port #!false))))) + +; +; READ-LINE re-coded in assembly language on 2-10-86 by TC +; +;(define read-line ; READ-LINE +; (lambda args +; (define (readln-rec port n char char-list) +; (cond ((eof-object? char) +; (if (null? char-list) +; char +; (fill-string (trim char-list)))) +; ((eqv? char #\return) +; (if (null? char-list) +; "" +; (fill-string (trim char-list)))) +; ((eqv? char #\newline) +; (readln-rec port n (read-char port) char-list)) +; (else +; (readln-rec port (+ n 1) (read-char port) +; (cons char char-list))))) +; (define (trim char-list) +; (cond ((null? char-list) +; '()) +; ((eqv? (car char-list) #\space) +; (trim (cdr char-list))) +; (else +; char-list))) +; (define (fill-string char-list) +; (let ((size (length char-list))) +; (fill-rec char-list (- size 1) (make-string size '())))) +; (define (fill-rec char-list i string) +; (if (null? char-list) +; string +; (begin +; (string-set! string i (car char-list)) +; (fill-rec (cdr char-list) (- i 1) string)))) +; (let ((port (and args (car args)))) +; (readln-rec port 0 (read-char port) '())))) +; + +(define set-line-length! ; SET-LINE-LENGTH! + (lambda (value . rest) + (%reify-port! (car rest) 5 value) + '())) + + +(define transcript-on) +(define transcript-off) + +(let ((port '())) + (set! transcript-on ; TRANSCRIPT-ON + (lambda (file) + (when (not (null? port)) + (transcript-off)) + (cond ((string? file) + (set! port (open-extend-file file)) + (if (port? port) + (begin + (%transcript port) + 'ok ) + (begin + (set! port '()) + (error "Unable to open transcript file" file)))) + ((window? file) + (set! port file) + (%transcript file) + 'ok) + (else + (error "Invalid argument to transcript-on" file))))) + + (set! transcript-off ; TRANSCRIPT-OFF + (lambda () + (when (not (null? port)) + (%transcript '()) + (close-output-port port) + (set! port '())) + 'ok))) + + +;;; WITH-INPUT-FROM-FILE and WITH-OUTPUT-TO-FILE need to be rewritten +;;; to use DYNAMIC-WIND, or its equivalent. + + +(define with-input-from-file ; WITH-INPUT-FROM-FILE + (lambda (filename thunk) + (let ((port (open-input-file filename))) + (if (port? port) + (let ((ans (fluid-let ((input-port port)) (thunk)))) + (close-input-port port) + ans) + port)))) + + +(define with-output-to-file ; WITH-OUTPUT-TO-FILE + (lambda (filename thunk) + (let ((port (open-output-file filename))) + (if (port? port) + (let ((ans (fluid-let ((output-port port)) (thunk)))) + (close-output-port port) + ans) + port)))) + + +(define window? ; WINDOW? + (lambda (obj) + (and (port? obj) + (positive? (%logand (%reify-port obj 11) %window-flag))))) + + +(define writeln ; WRITELN + (lambda args + (do ((args args (cdr args))) + ((null? args) + (newline)) + (display (car args))))) + +;**************************************************************************** +;* SET-FILE-POSITION will move the file pointer to a new position * +;* and update a pointer in the buffer to point to a new location. * +;* The offset variable can be: * +;* 0 for positioning from the start of the file * +;* 1 for positioning relative to the current position * +;* 2 for positioning from the end of the file * +;**************************************************************************** + +(define set-file-position! ; SET-FILE-POSITION! + (lambda (port #-of-bytes offset) + (let ((current-pos (%reify-port port 9)) + (end-of-buffer (%reify-port port 10)) + (new-pos '()) + (current-chunk (max 0 (-1+ (%reify-port port 12)))) + (new-chunk '()) + (messages '()) + (file-size (+ (* (%reify-port port 4) 65536) (%reify-port port 6))) + (port-flags (%reify-port port 11))) + (if (and (port? port) + (=? (%logand port-flags %window-flag) 0)) + (case offset + ((0) ; offset from the start of the file + (set! #-of-bytes (abs #-of-bytes)) + (if (=? (%logand port-flags %write-file-flag) 0) + (set! #-of-bytes (min #-of-bytes file-size))) + (set! new-chunk (truncate (/ #-of-bytes 256))) + (set! new-pos (- #-of-bytes (* new-chunk 256))) + (if (and (=? new-pos 0) + (=? (%logand port-flags %write-file-flag) 0) ; open for reading + (=? new-chunk current-chunk)) + (%reify-port! port 9 new-pos) + (%sfpos port new-chunk new-pos))) + + ((1) ; offset from the current position + (set! new-pos (+ current-pos #-of-bytes)) + (if (and (=? new-pos 0) + (=? (%logand port-flags %write-file-flag) 0)) ; open for reading + (%reify-port! port 9 new-pos) + (begin + (set! new-pos (+ (+ current-pos (* 256 current-chunk)) + #-of-bytes)) ; offset from the begining of the file + (if (and (>? new-pos file-size) + (=? (%logand port-flags %write-file-flag) 0)) + (set! new-pos file-size)) + (if (=? new-pos 0) + (=? new-chunk current-chunk)) + (%reify-port! port 9 new-pos) + (%sfpos port new-chunk new-pos)) + (error + "SET-FILE-POSITION! - offset from EOF only valid for input files") + )) + (else (%error-invalid-operand 'SET-FILE-POSITION! offset))) + (%error-invalid-operand 'SET-FILE-POSITION! port))))) + +;****************************************************************** +;* get-file-position will return the current file position in the * +;* number of bytes from the beginning of the file. * +;****************************************************************** + +;(define get-file-position +; (lambda (port) +; (let (( result '()) +; (chunk (max 1 (%reify-port port 12)))) +; (if (and (port? port) +; (=? (%logand (%reify-port port 11) %window-flag) 0)) +; (set! result (+ (* 256 (-1+ chunk)) ; chunk# +; (%reify-port port 9))) ; current position +; (set! result "Needs to be a port/file object!")) +; result))) + +(define get-file-position ; GET-FILE-POSITION + (lambda (port) + (if (and (port? port) + (=? (%logand (%reify-port port 11) %window-flag) 0)) + (+ (* 256 (-1+ (max 1 (%reify-port port 12)))) ; chunk# + (%reify-port port 9)) ; offset within chunk + (error "Invalid argument to GET-FILE-POSITION. Port object must represent a file." port)))) + \ No newline at end of file diff --git a/newpcs/pmacros.s b/newpcs/pmacros.s new file mode 100644 index 0000000..586f05e --- /dev/null +++ b/newpcs/pmacros.s @@ -0,0 +1,719 @@ + +; -*- Mode: Lisp -*- Filename: pmacros.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985, 1987 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Standard Macro Definitions ; +; ; +;--------------------------------------------------------------------------; + + +; Revision history: +; db 10/04/85 - original +; rb 05/23/86 - treat (define var form1 ...) illegal--when "var" is a symbol, +; there can be at most 1 form in the body +; tc 1/27/87 - Included new quasiquote expand. +; tc 2/10/87 - changed unfold-define so that MIT style define is not expanded +; into named-lambda unless pcs-integrate-define is #T. This is +; required for the R^3 Report. +; rb 4/ 5/87 - included XCALL macro for XLI + + +; runtime version of CREATE-SCHEME-MACRO is in PSTL.S +; (because this file isn't used when making runtime system) +(define create-scheme-macro ; CREATE-SCHEME-MACRO + (lambda (name handler) + (putprop name handler 'PCS*MACRO) + name)) + +(define %expand-syntax-form ; %EXPAND-SYNTAX-FORM + (lambda (form pat exp) + (letrec + ((compare + (lambda (f p) + (cond ((atom? p) + (cond ((symbol? p) + (list (cons p f))) + ((and (null? p) (null? f)) + '()) + (else (oops)))) + ((atom? f) + (oops)) + ((atom? (car p)) + (cons (cons (car p)(car f)) + (compare (cdr f)(cdr p)))) + (else + (append! (compare (car f)(car p)) + (compare (cdr f)(cdr p))))))) + (substitute + (lambda (id-list exp) + (cond ((pair? exp) + (cons (substitute id-list (car exp)) + (substitute id-list (cdr exp)))) + ((symbol? exp) + (let ((x (assq exp id-list))) + (if (null? x) + exp + (cdr x)))) + (else exp)))) + (oops + (lambda () + (syntax-error "Invalid special form" form)))) + + (substitute (compare (cdr form) pat) exp)))) + +(letrec + ((csm + (lambda (name handler) + (putprop name handler 'PCS*MACRO))) + + (make-begin + (lambda (x) + (if (cdr x) (cons 'BEGIN x) (car x)))) + + (unfold-define + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((op (car form)) ; DEFINE or DEFINE-INTEGRABLE + (spec (cadr form)) ; ID or (spec . bvl) + (body (cddr form))) ; rest after removing first 2 elts + (cond ((null? body) + (unfold-define `(,op ,spec '#!UNASSIGNED))) + ((pair? spec) + (let ((name (car spec)) + (bvl (cdr spec))) + (pcs-chk-bvl form bvl #!true) + (unfold-define + (if (pair? name) + `(,op ,name (LAMBDA ,bvl . ,body)) + (if pcs-integrate-define + `(,op ,name (NAMED-LAMBDA ,spec . ,body)) + `(,op ,name (LAMBDA ,bvl . ,body))) )))) + (else + (pcs-chk-length= form form 3) + form))))) + + ;; EXPAND-QUASIQUOTE is adapted from an algorithm placed in + ;; the public domain (the RRRS-Authors mailing list) on + ;; 22-Dec-86 by Jonathan Rees of MIT. + + + (expand-quasiquote + (lambda (x level) + (descend-quasiquote x level finalize-quasiquote))) + + (finalize-quasiquote + (lambda (mode arg) + (cond ((eq? mode 'QUOTE) `',arg) + ((eq? mode 'UNQUOTE) arg) + ((eq? mode 'UNQUOTE-SPLICING) + (syntax-error ",@ in illegal context" arg)) + ((eq? mode 'UNQUOTE-SPLICING!) + (syntax-error ",. in illegal context" arg)) + (else `(,mode ,@arg))))) + + (descend-quasiquote + (lambda (x level return) + (cond ((vector? x) + (descend-quasiquote-vector x level return)) + ((not (pair? x)) + (return 'QUOTE x)) + ((eq? (car x) 'QUASIQUOTE) + (descend-quasiquote-pair x (+ level 1) return)) + ((memq (car x) '(UNQUOTE UNQUOTE-SPLICING UNQUOTE-SPLICING!)) + (if (zero? level) + (return (car x) (cadr x)) + (descend-quasiquote-pair x (- level 1) return))) + (else + (descend-quasiquote-pair x level return))))) + + (descend-quasiquote-pair + (lambda (x level return) + (descend-quasiquote (car x) level ; process (car x) + (lambda (car-mode car-arg) + (descend-quasiquote (cdr x) level ; process (cdr x) + (lambda (cdr-mode cdr-arg) + (cond ((and (eq? car-mode 'QUOTE) + (eq? cdr-mode 'QUOTE)) + (return 'QUOTE x)) + ((eq? car-mode 'UNQUOTE-SPLICING) ; (,@foo ...) + (if (and (eq? cdr-mode 'QUOTE) + (null? cdr-arg)) + (return 'UNQUOTE car-arg) + (return 'APPEND + (list car-arg + (finalize-quasiquote + cdr-mode cdr-arg))))) + ((eq? car-mode 'UNQUOTE-SPLICING!) ; (,.foo ...) + (if (and (eq? cdr-mode 'QUOTE) + (null? cdr-arg)) + (return 'UNQUOTE car-arg) + (return 'APPEND! + (list car-arg + (finalize-quasiquote + cdr-mode cdr-arg))))) + (else + (return 'CONS + (list (finalize-quasiquote car-mode car-arg) + (finalize-quasiquote cdr-mode cdr-arg) + ))) + ))))))) + + (descend-quasiquote-vector + (lambda (x level return) + (descend-quasiquote (vector->list x) level + (lambda (mode arg) + (if (eq? mode 'QUOTE) + (return 'QUOTE x) + (return 'LIST->VECTOR + (list (finalize-quasiquote mode arg)))))))) + ) + + +;---- begin LETREC body ---- + +(csm 'access ; ACCESS + (lambda (form) + (letrec ((help + (lambda (form L) + (let ((sym (car L)) + (env (if (null? (cddr L)) ; (access sym env) + (cadr L) + (list 'CDR (help form (cdr L)))))) + (pcs-chk-id form sym) + `(%ENV-LU (QUOTE ,sym) ,env))))) + (pcs-chk-length>= form form 2) + (let ((id (cadr form))) + (pcs-chk-id form id) + (if (null? (cddr form)) + id ; (access id) + (list '%CDR + (help form (cdr form)))))))) + + +(csm 'alias ; ALIAS + (lambda (form) + (pcs-chk-length= form form 3) + (let ((id (cadr form)) + (exp (caddr form))) + (pcs-chk-id form id) + `(CREATE-SCHEME-MACRO + ',id + (CONS 'ALIAS ',exp))))) + + +(csm 'and ; AND + (lambda (form) + (pcs-chk-length>= form form 1) + (cond ((null? (cdr form)) #!true) + ((null? (cddr form)) (cadr form)) + (else `(IF ,(cadr form) + (AND . ,(cddr form)) + #!FALSE))))) + + +(csm 'apply-if ; APPLY-IF + (lambda (form) + (pcs-chk-length= form form 4) + (let ((pred (cadr form)) + (fn (caddr form)) + (body (cadddr form))) + `(LET ((%00000 ,pred)) + (IF %00000 (,fn %00000) + ,body))))) + +(csm 'assert ; ASSERT + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((pred (cadr form)) + (msg (cons 'LIST (cddr form))) + (env (if pcs-debug-mode '(THE-ENVIRONMENT) '()))) + `(IF ,pred + '() + (BEGIN (ASSERT-PROCEDURE ,msg ,env) + '()))))) ; make call non-tail-recursive + +(csm 'begin0 ; BEGIN0 + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((first (cadr form)) + (rest (cddr form))) + `(LET ((%00000 ,first)) + (BEGIN ,@rest %00000))))) + + +(csm 'bkpt ; BKPT + (lambda (form) + (pcs-chk-length= form form 3) + `(BEGIN (BREAKPOINT-PROCEDURE ,(cadr form) + ,(caddr form) + (THE-ENVIRONMENT)) + '()))) ; make call non-tail-recursive + +(csm 'case ; CASE + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((tag (cadr form)) + (pairs (cddr form))) + `(LET ((%00000 ,tag)) + ,(let loop ((p pairs)) + (if (null? p) + p + (let ((clause (car p))) + (pcs-chk-length>= clause clause 2) + (let ((match (if (and (pair? (car clause)) + (atom? (caar clause)) + (null? (cdar clause))) + (caar clause) + (car clause))) + (result `(BEGIN . ,(cdr clause)))) + (if (and (null? (cdr p)) + (eq? match 'ELSE)) + result + (let ((test (if (pair? match) 'MEMV 'EQV?))) + `(IF (,test %00000 ',match) + ,result + ,(loop (cdr p))))))))))))) + + +(csm 'cond ; COND + (lambda (form) + (pcs-chk-length>= form form 1) + (let ((e (cdr form))) + (if (null? e) + e + (let ((clause (car e))) + (pcs-chk-length>= form clause 1) + (if (and (null? (cdr e)) + (eq? (car clause) 'ELSE)) ; T handled by PME/PSIMP + (if (null? (cdr clause)) + #!true + (make-begin (cdr clause))) ; exp + (let ((test (car clause)) ; a + (then (cdr clause))) ; b + (if (null? (cdr e)) ; (... (a b)) + (if (null? then) + test + `(IF ,test ,(make-begin then) #!FALSE)) + (if (null? then) + `(OR ,test + (COND . ,(cdr e))) + `(IF ,test ,(make-begin then) + (COND . ,(cdr e)))))))))))) + + +(csm 'cons-stream ; CONS-STREAM + (lambda (form) + (pcs-chk-length= form form 3) + `(VECTOR '#!STREAM + ,(cadr form) + (%DELAY (LAMBDA () ,(caddr form)))))) + + +(csm 'define ; DEFINE + (lambda (form) + (unfold-define form))) + + +(csm 'define-integrable ; DEFINE-INTEGRABLE + (lambda (form) + (pcs-chk-length= form form 3) + (let* ((form (unfold-define form)) + (id (cadr form)) + (exp (caddr form))) + (pcs-chk-id form id) + `(BEGIN + (PUTPROP ',id + (CONS 'DEFINE-INTEGRABLE ',exp) + 'PCS*PRIMOP-HANDLER) + (QUOTE ,id))))) + + +(csm 'define-structure ; DEFINE-STRUCTURE + (lambda (form) + (%define-structure form))) + + +(csm 'delay ; DELAY + (lambda (form) + (pcs-chk-length= form form 2) + `(VECTOR '#!DELAYED-OBJECT + (%DELAY (LAMBDA () ,(cadr form)))))) + + +(csm 'do ; DO + (lambda (form) + (letrec ((triplify + (lambda (old new) + (if (atom? old) + (if (null? old) + (reverse! new) + (syntax-error "Invalid DO triples list: " form)) + (let* ((x (car old)) + (y (cond ((atom? x) + (list x '() x)) + ((atom? (cdr x)) + (list (car x) '() (car x))) + ((atom? (cddr x)) + (list (car x)(cadr x)(car x))) + ((null? (cdddr x)) + x) + (else (syntax-error + "Invalid DO list item: " + x))))) + (pcs-chk-id x (car y)) + (triplify (cdr old)(cons y new))))))) + (pcs-chk-length>= form form 3) + (let* ((triples (triplify (cadr form) '())) + (vars (mapcar car triples)) + (inits (mapcar cadr triples)) + (steps (mapcar caddr triples)) + (term (caddr form))) + (pcs-chk-length>= form term 1) + (let* ((test (car term)) + (body `(BEGIN ,@(cdddr form) (%00000 . ,steps))) + (loop (if (null? (cdr term)) + `(LET ((%00001 ,test)) + (IF %00001 %00001 ,body)) + `(IF ,test (BEGIN . ,(cdr term)) ,body)))) + `((REC %00000 + (LAMBDA ,vars ,loop)) + . ,inits)))))) + + +(csm 'error ; ERROR + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((msg (cadr form)) + (irr (cond ((null? (cddr form)) + '()) + ((null? (cdddr form)) + (caddr form)) + (else + (cons 'LIST (cddr form))))) + (env (if pcs-debug-mode '(THE-ENVIRONMENT) '()))) + `(BEGIN (ERROR-PROCEDURE ,msg ,irr ,env) + '())))) ; make call non-tail-recursive + +(csm 'fluid ; FLUID + (lambda (form) + (pcs-chk-length= form form 2) + (pcs-chk-id form (cadr form)) + `(%%GET-FLUID%% (QUOTE ,(cadr form))))) + + +(csm 'fluid-bound? ; FLUID-BOUND? + (lambda (form) + (pcs-chk-length= form form 2) + (pcs-chk-id form (cadr form)) + `(%%FLUID-BOUND?%% (QUOTE ,(cadr form))))) + + +(csm 'fluid-lambda ; FLUID-LAMBDA + (lambda (form) + (letrec + ((add-bindings + (lambda (bvl fvl body-list) + (if (null? bvl) + (cons 'BEGIN body-list) + (add-bindings (cdr bvl) (cdr fvl) + `((%%BIND-FLUID%% + (QUOTE ,(car fvl)) + ,(car bvl)) + . ,body-list)))))) + (pcs-chk-length>= form form 3) + (pcs-chk-bvl form (cadr form) #!false) + (if (null? (cadr form)) + (cons 'LAMBDA (cdr form)) + (let* ((fvl (cadr form)) + (bvl (mapcar (lambda (fv)(gensym '*)) + fvl)) + (ans (gensym '*)) + (body (cons 'BEGIN (cddr form)))) + (list 'LAMBDA + bvl + (add-bindings + (reverse bvl) ; don't use REVERSE! + (reverse fvl) + `((LET ((,ans ,body)) + (BEGIN + (%%UNBIND-FLUID%% ',fvl) + ,ans)))))))))) + + +(csm 'fluid-let ; FLUID-LET + (lambda (form) + (pcs-chk-length>= form form 3) + (let ((pairs (cadr form)) + (body (cddr form))) + (pcs-chk-pairs form pairs) + `((FLUID-LAMBDA ,(mapcar car pairs) + (BEGIN . ,body)) + . ,(mapcar cadr pairs))))) + + +(csm 'freeze ; FREEZE + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((body (cdr form))) + `(LAMBDA () . ,body)))) + +(csm 'inspect ; INSPECT + (lambda (form) + (pcs-chk-length>= form form 1) + (let ((env (if (cdr form) + (begin + (pcs-chk-length= form form 2) + (cadr form)) + '(THE-ENVIRONMENT)))) + `(begin + (%inspect ,env) + *the-non-printing-object*)))) + +(csm 'let ; LET + (lambda (form) + (pcs-chk-length>= form form 3) + (if (and (symbol? (cadr form)) ; named LET + (not (null? (cadr form)))) + (begin + (pcs-chk-length>= form form 4) + (let ((name (cadr form)) + (pairs (caddr form)) + (body (cdddr form))) + (pcs-chk-pairs form pairs) + `((REC ,name (LAMBDA ,(mapcar car pairs) . ,body)) + . ,(mapcar cadr pairs)))) + (let ((pairs (cadr form)) ; unnamed LET + (body (cddr form))) + (pcs-chk-pairs form pairs) + `((LAMBDA ,(mapcar car pairs) + . ,body) + . ,(mapcar cadr pairs)))))) + + +(csm 'let* ; LET* + (lambda (form) + (pcs-chk-length>= form form 3) + (let ((pairs (cadr form)) + (body (cddr form))) + (if (null? pairs) + `(BEGIN . ,body) + (begin + (pcs-chk-pairs form pairs) + (let ((id (caar pairs)) + (exp (cadar pairs))) + `((LAMBDA (,id) + (LET* ,(cdr pairs) . ,body)) + ,exp))))))) + + +(csm 'macro ; MACRO + (lambda (form) + (pcs-chk-length= form form 3) + (let ((id (cadr form)) + (fn (caddr form))) + (pcs-chk-id form id) + `(CREATE-SCHEME-MACRO (QUOTE ,id) ,fn)))) + + +(csm 'make-environment ; MAKE-ENVIRONMENT + (lambda (form) + (pcs-chk-length>= form form 1) + `(LET () + ,@(cdr form) + (THE-ENVIRONMENT)))) + +(csm 'make-hashed-environment ; MAKE-HASHED-ENVIRONMENT + (lambda (form) + (pcs-chk-length>= form form 1) + `(LET () + (%make-hashed-environment)))) + +(csm 'named-lambda ; NAMED-LAMBDA + (lambda (form) + (pcs-chk-length>= form form 3) + (let ((bvl+ (cadr form))) + (pcs-chk-bvl form bvl+ (not (atom? bvl+))) + (let ((name (car bvl+)) + (bvl (cdr bvl+)) + (body (cddr form))) + `(REC ,name (LAMBDA ,bvl . ,body)))))) + + +(csm 'or ; OR + (lambda (form) + (pcs-chk-length>= form form 1) + (cond ((null? (cdr form)) #!false) + ((null? (cddr form)) (cadr form)) + ((or (atom? (cadr form)) + (eq? (car (cadr form)) 'QUOTE)) + `(IF ,(cadr form) ,(cadr form) + (OR . ,(cddr form)))) + (else + `(LET ((%00000 ,(cadr form))) + (IF %00000 %00000 + (OR . ,(cddr form)))))))) + + +(csm 'quasiquote ; QUASIQUOTE + (lambda (form) + (pcs-chk-length= form form 2) + (expand-quasiquote (cadr form) 0))) + + +(csm 'rec ; REC + (letrec ((nice-bvl? + (lambda (bvl) + (cond ((null? bvl) #!true) + ((atom? bvl) #!false) + ((eq? (car bvl) '#!OPTIONAL) #!false) + (else (nice-bvl? (cdr bvl))))))) + (lambda (form) + (pcs-chk-length= form form 3) + (let ((id (cadr form)) + (exp (caddr form))) + (pcs-chk-id form id) + (if (and (not pcs-debug-mode) + (pair? exp) + (eq? (car exp) 'LAMBDA) + (pair? (cdr exp)) + (nice-bvl? (cadr exp))) + (let ((bvl (cadr exp))) + `(LETREC ((,id ,exp)) + (LAMBDA ,bvl (,id . ,bvl)))) + `(LETREC ((,id ,exp)) ,id)))))) + + +(csm 'sequence ; SEQUENCE + (lambda (form) + (pcs-chk-length>= form form 1) + (cons 'BEGIN (cdr form)))) + + +(csm 'set-fluid! ; SET-FLUID! + (lambda (form) + (pcs-chk-length= form form 3) + (pcs-chk-id form (cadr form)) + `(%%SET-FLUID%% (QUOTE ,(cadr form)) + ,(caddr form)))) + + +(csm 'set! ; SET! + (lambda (form) + (pcs-chk-length= form form 3) + (let ((spec (cadr form)) + (value (caddr form))) + (if (pair? spec) + (let ((op (car spec))) + (case op + ((ACCESS) + (pcs-chk-length>= spec spec 2) + (let ((sym (cadr spec)) + (env (cond ((null? (cddr spec)) + '(THE-ENVIRONMENT)) + ((null? (cdddr spec)) + (caddr spec)) + (else + `(ACCESS . ,(cddr spec)))))) + (pcs-chk-id spec sym) + + `(LET ((%00000 ,env)) + (%DEFINE ',sym ,value %00000) + '()) + +;;; `(LET* ((%00000 ; do this first, since it +;;; ,env) ; may be (THE-ENVIRONMENT) +;;; (%00001 ,value) +;;; (%00002 (%SET-GLOBAL-ENVIRONMENT %00000))) +;;; (%%DEF-GLOBAL%% ',sym %00001) +;;; (%SET-GLOBAL-ENVIRONMENT %00002) +;;; '()) + + )) + ((FLUID) + (pcs-chk-length= spec spec 2) + (pcs-chk-id spec (cadr spec)) + `(SET-FLUID! ,(cadr spec) ,value)) + ((VECTOR-REF) + (pcs-chk-length= spec spec 3) + `(VECTOR-SET! ,(cadr spec) ,(caddr spec) ,value)) + (else + (let ((mac (getprop op 'PCS*MACRO))) + (if (null? mac) + (let ((g (getprop op 'PCS*PRIMOP-HANDLER))) + (if (and (pair? g) + (eq? (car g) 'DEFINE-INTEGRABLE) + (pair? (cdr g)) + (eq? (cadr g) 'LAMBDA) + (pair? (cddr g)) + (pair? (cdddr g)) + (null? (cddddr g))) + (let ((args (caddr g)) + (body (cadddr g))) + `((LAMBDA ,args (SET! ,body ,value)) + ,@(cdr spec))) + form)) + `(SET! ,(if (pair? mac) + (cons (cdr mac)(cdr spec)) ; alias + (mac spec)) ; macro + ,value)))))) + form)))) + + +(csm 'syntax ; SYNTAX + (lambda (form) + (pcs-chk-length= form form 3) + (let ((pat (cadr form)) + (exp (caddr form))) + (if (and (pair? pat)(symbol? (car pat))) + `(CREATE-SCHEME-MACRO + ',(car pat) ; macro name + (LAMBDA (FORM) + (%EXPAND-SYNTAX-FORM FORM ',(cdr pat) ',exp))) + (syntax-error "Invalid SYNTAX form: " form))))) + + +(csm 'unassigned? ; UNASSIGNED? + (lambda (form) + (pcs-chk-length= form form 2) + (let ((sym (cadr form))) + (pcs-chk-id form sym) + `(EQ? ,sym '#!UNASSIGNED)))) + + +(csm 'unbound? ; UNBOUND? + (lambda (form) + (pcs-chk-length>= form form 2) + (let ((sym (cadr form)) + (env (cond ((null? (cddr form)) + (list 'THE-ENVIRONMENT)) + ((null? (cdddr form)) + (caddr form)) + (else + (cons 'ACCESS (cddr form)))))) + (pcs-chk-id form sym) + `(NULL? (%ENV-LU (QUOTE ,sym) ,env))))) + +(csm 'xcall ; XCALL (for XLI) + (lambda (e) + (pcs-chk-length>= e e 2) + (let ((fn (cadr e)) + (args (cddr e))) + `(%xesc ,(+ (length args) 2) ,fn ,@args)))) + + +(csm 'when ; WHEN + (lambda (form) + (pcs-chk-length>= form form 3) + (let ((pred (cadr form)) + (body (cons 'BEGIN (cddr form)))) + `(IF ,pred ,body '())))) + +'() +) ;---- end LETREC body ---- + \ No newline at end of file diff --git a/newpcs/pmath.s b/newpcs/pmath.s new file mode 100644 index 0000000..5a9ea03 --- /dev/null +++ b/newpcs/pmath.s @@ -0,0 +1,155 @@ + +; -*- Mode: Lisp -*- Filename: pmath.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1987 (c) Texas Instruments ; +; All Rights Reserved ; +; ; +; Extended Arithmetic Routines using XLI/Lattice C 8087/80287 NDP support ; +; ; +; Bob Beal ; +; ; +;--------------------------------------------------------------------------; + + +(define exact? (lambda (n) #f)) + +(define inexact? (lambda (n) #t)) + +(begin + (define acos) + (define asin) + (define atan) + (define cos) + (define exp) + (define expt) + (define log) + (define sin) + (define sqrt) + (define tan) + (define pi) + ) + +(letrec + ( +; ( *pi* 3.141592653589793) ; pi +; ( *pi/2* (/ *pi* 2)) ; pi/2 +; ( *2pi* (+ *pi* *pi*)) ; 2pi + ( *e* 2.718281828459045) ; e + + (%bad-argument + (lambda (name arg) + (%error-invalid-operand name arg))) + + (power-loop + (lambda (x n a) ; A is initially 1, N is non-negative + (if (zero? n) + a + (power-loop (* x x) + (quotient n 2) + (if (odd? n) (* a x) a))))) + ) + (begin + + (set! sqrt + (lambda (x) + (if (or (not (number? x)) (negative? x)) + (%bad-argument 'sqrt x) + (let ((x (float x))) + (if (zero? x) + x + (xcall "sqrt" (float x))))))) + (set! sin + (lambda (x) + (if (not (number? x)) + (%bad-argument 'sin x) + (xcall "sin" (float x))))) + + (set! cos + (lambda (x) + (if (not (number? x)) + (%bad-argument 'cos x) + (xcall "cos" (float x))))) + + + (set! tan + (lambda (x) + (if (not (number? x)) + (%bad-argument 'tan x) + (xcall "tan" (float x))))) + + (set! atan + (lambda (x . z) + (cond ((not (number? x)) + (%bad-argument 'atan x)) + ((null? z) + (xcall "atan" (float x))) + ((not (number? (car z))) + (%bad-argument 'atan z)) + (else + (xcall "atan2" (float x) (float (car z))))))) + + (set! acos + (lambda (x) + (if (or (not (number? x)) + (>? (abs x) 1.0)) + (%bad-argument 'ACOS x) + (xcall "acos" (float x))))) + + (set! pi (acos -1)) ;it'd be easier to set pi to a constant but make_fsl + ;is not quite up to 8087 long-real precision on + ;literal constants (e.g. (tan (/ pi 4)) is +/- 2 + ;in the last digit via make_fsl, but +/- 0 if typed + ;in at toplevel or computed as here) + + (set! asin + (lambda (x) + (if (or (not (number? x)) + (>? (abs x) 1.0)) + (%bad-argument 'ASIN x) + (xcall "asin" (float x))))) + + (set! log + (lambda (x . base) + (cond ((or (not (number? x)) (<= x 0)) + (%bad-argument 'log x)) + ((null? base) + (xcall "ln" (float x))) + ((eq? (car base) 10) ;the eq? is deliberate + (xcall "log10" (float x))) + ((= (car base) 1.0) + (error "Divide by zero" 'log x (car base))) + (else + (let ((non-e-base (car base))) + (if (or (not (number? non-e-base)) + (not (positive? non-e-base))) + (%bad-argument 'log non-e-base) + (xcall "log" (float x) (float non-e-base)))))))) + + (set! exp + (lambda (x) + (cond ((not (number? x)) + (%bad-argument 'EXP x)) + ((zero? x) 1.0) + ((negative? x) (/ (xcall "exp" (- (float x))))) + ((integer? x) (power-loop *e* x 1)) + (else + (xcall "exp" (float x)))))) + + (set! expt + (lambda (a x) + (cond ((not (number? a)) + (%bad-argument 'EXPT a)) + ((not (number? x)) + (%bad-argument 'EXPT x)) + ((and (zero? a) (zero? x) (not (integer? x))) + (%bad-argument 'EXPT x)) + ((zero? x) (if (integer? a) 1 1.0)) + ((negative? x) (/ (xcall "expt" (float a) (- (float x))))) + ((integer? x) (power-loop a x 1)) + (else + (xcall "expt" (float a) (float x)))))) + )) + \ No newline at end of file diff --git a/newpcs/pme.s b/newpcs/pme.s new file mode 100644 index 0000000..e8515a8 --- /dev/null +++ b/newpcs/pme.s @@ -0,0 +1,504 @@ + +; -*- Mode: Lisp -*- Filename: pme.s + +; Last Revision: 1-Oct-85 1400ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Macro Expansion and Alpha Conversion ; +; ; +;--------------------------------------------------------------------------; +; +; Alpha conversion technique: +; +; All lexical identifiers (not global or fluid variables) are changed +; to "id records" organized as shown: +; +; (T (original-name . unique-number) . ) +; +; The tag "T" is used because it does not conflict with any valid +; names for primitive operations. The "unique-number" is for human +; consumption but may also be used to create an assembler label. +; +; Global and fluid variables are not considered in the "core". The +; following primitive functions are used to manipulate them: +; +; (%%get-global%% (quote symbol)) +; (%%set-global%% (quote symbol) exp) +; (%%def-global%% (quote symbol) exp) +; +; (%%get-fluid%% (quote symbol)) +; (%%set-fluid%% (quote symbol) exp) +; +; (%%bind-fluid%% (quote symbol) exp) +; (%%unbind-fluid%% (quote (symbol ...))) +; (%%fluid-bound?%% (quote symbol)) +; +; Names of official SCHEME 84 primitive functions are not considered +; to be global variables. When used in the function position of a +; combination, they are left as atoms. Funarg uses of such +; primitives are changed to dummy closures: +; +; (foo eq?) ==> (foo (lambda (a b) (eq? a b))) +; +; Node annotation: +; +; Lambda and mulambda nodes are extended with extra "slots" for use +; during closure analysis as follows. Mulambda's are represented by +; a negative argument count and a "normalized" argument list. +; +; (lambda bvl body nargs label debug closed?) +; +;--------------------------------------------------------------------------; + + + + +(define pcs-macro-expand ; PCS-MACRO-EXPAND + (lambda (exp) + (letrec +;------! + ( + (chk-id (lambda (e y) (pcs-chk-id e y))) ; syntax checkers + (chk-length= (lambda (e y n) (pcs-chk-length= e y n))) + (chk-length>= (lambda (e y n) (pcs-chk-length>= e y n))) + (chk-bvl (lambda (a b c) (pcs-chk-bvl a b c))) + (chk-pairs (lambda (a b) (pcs-chk-pairs a b))) + + (expand + (lambda (x env) + (cond ((atom? x) + (exp-atom x env)) + ((macro? (car x)) + (exp-macro x env)) + (else + (expand2 x env))))) + + (exp-macro + (lambda (x env) + (let ((y (if (pair? macfun) + (cons (cdr macfun)(cdr x)) ; alias + (macfun x)))) ; macro + (if (or (atom? y) + (equal? x y)) + (expand2 y env) + (expand y env))))) + + (macfun '()) + + (macro? + (lambda (id) + (set! macfun + (and (symbol? id) + (or (getprop id 'PCS*MACRO)))) + macfun)) + + (expand2 + (lambda (x env) + (if (atom? x) + (exp-atom x env) + (case (car x) + (quote (exp-quote x)) + (lambda (exp-lambda x env)) + (if (exp-if x env)) + (set! (exp-set! x env)) + (define (exp-define x env)) + (begin (exp-begin x env)) + (letrec (exp-letrec x env)) + (not (exp-not x env)) + (else (exp-application x env)) + )))) + + (exp-quote + (lambda (x) + (chk-length= x x 2) + x)) + + (exp-atom + (lambda (x env) + (let ((info (assq x '((T . '#!TRUE)(NIL . '()))))) + (cond (info + (if integrate-T-and-NIL? + (cdr info) + (lookup x env))) + ((or (null? x) + (not (symbol? x)) + (memq x '(#!TRUE #!FALSE #!UNASSIGNED))) + (list 'QUOTE x)) + (else + (lookup x env)))))) + + (exp-lambda + (lambda (x env) + (chk-length>= x x 3) + (let ((bvl (lambda-bvl x))) + (chk-bvl x bvl #!true) + (let ((node (help-lambda bvl + (make-contour (lambda-body-list x) env '()) + '() 0 env))) + (let ((name (fluid name))) ; guess at closure name + (set-lambda-debug node + (if pcs-debug-mode + (cons (cons 'SOURCE x) name) + name))) + node)))) + + (make-contour + (lambda (sl env pairs) + (if (or (null? sl) + (atom? (car sl))) + (make-letrec sl env pairs) + (let* ((s (car sl)) + (op (car s))) + (if (macro? op) + (let* ((y (if (pair? macfun) + (cons (cdr macfun)(cdr s)) ; alias + (macfun s))) ; macro + (sl (cons y (cdr sl)))) + (if (equal? s y) + (help-contour sl env pairs) ; exit loop + (make-contour sl env pairs))) ; repeat loop + (help-contour sl env pairs)))))) + + (help-contour + (lambda (sl env pairs) + (let ((s (car sl))) + (case (car s) + (DEFINE + (let* ((name (cadr s)) + (exp (caddr s)) + (pair (if (and (symbol? name) + (pair? exp) + (eq? (car exp) 'NAMED-LAMBDA) + (pair? (cdr exp)) + (pair? (cadr exp)) + (eq? (car (cadr exp)) name)) + (let ((bvl (cdr (cadr exp))) + (bdy (cddr exp))) + `(,name (LAMBDA ,bvl . ,bdy))) + (cdr s)))) + (make-contour (cdr sl) env (cons pair pairs)))) + (BEGIN + (make-contour (append (cdr s)(cdr sl)) env pairs)) + (else + (make-letrec sl env pairs)))))) + + (make-letrec + (lambda (sl env pairs) + (if (null? pairs) + (make-body sl) + `(LETREC ,(reverse! pairs) . ,sl)))) + + (help-lambda + (lambda (old-bvl body new-bvl nargs env) + (cond ((null? old-bvl) + (let* ((bvl (reverse! new-bvl)) + (env (extend env bvl))) + (pcs-extend-lambda + (list 'LAMBDA + (mapcar (lambda (id) (cdr (assq id env))) + bvl) + (expand body env) + nargs)))) + ((atom? old-bvl) ; mulambda + (help-lambda '() + body + (cons old-bvl new-bvl) + (minus (add1 nargs)) + env)) + (else + (help-lambda (cdr old-bvl) + body + (cons (car old-bvl) new-bvl) + (add1 nargs) + env))))) + +; Below, perform the optimization +; +; (if (or a b) x y) ===> (if (and (not a)(not b)) y x) +; +; which allows the AND macro to generate better code. + + (exp-if + (lambda (x env) + (if (or (atom? (cdr x))(atom? (cddr x))(atom? (cdddr x))) + (chk-length= x x 3) + (chk-length= x x 4)) + (let ((pred (if-pred x)) + (then (if-then x)) + (else (if (null? (cdddr x)) + ''() + (if-else x)))) + (if (and (not (atom? pred)) + (eq? (car pred) 'OR)) + (list 'IF + (expand (cons 'AND + (mapcar (lambda (arg) (list 'NOT arg)) + (cdr pred))) + env) + (expand else env) + (expand then env)) + (list 'IF + (expand pred env) + (expand then env) + (expand else env)))))) + +; Below, perform the optimization +; +; (not (or a b)) ===> (and (not a)(not b)) +; +; which allows the AND macro to generate better code. + + (exp-not + (lambda (x env) + (chk-length= x x 2) + (if (and (primitive? 'NOT env) + (pair? (cadr x)) + (eq? (car (cadr x)) 'OR)) + (expand + (cons 'AND (mapcar (lambda (opd) (list 'NOT opd)) + (cdr (cadr x)))) + env) + (exp-application x env)))) + + (exp-set! + (lambda (x env) + (chk-length= x x 3) + (let* ((id (set!-id x)) + (var (lookup-LHS id "SET!" env)) + (val (fluid-let ((name id)) + (expand (set!-exp x) env)))) + (if (atom? var) + `(%%SET-GLOBAL%% (QUOTE ,var) ,val) + `(SET! ,var ,val))))) + + (exp-define + (lambda (x env) + (chk-length>= x x 3) + (let* ((id (set!-id x)) + (var (lookup-LHS id "DEFINE" env)) + (val (fluid-let ((name id)) + (expand (set!-exp x) env)))) + (when (not (null? env)) + (syntax-error "Incorrectly placed DEFINE" x)) + (if (atom? var) + `(%%DEF-GLOBAL%% (QUOTE ,id) ,val) ; global + `(BEGIN (SET! ,var ,val) ; lexical + (QUOTE ,id)))))) + + (exp-begin + (lambda (x env) + (chk-length>= x x 1) + (make-body (mapcar (lambda (s) (expand s env)) + (help-begin (cdr x) '()))))) + +; Below, perform the optimization +; +; (begin ... (or a ...) ...) ==> (begin ... (and (not a)...) ...) +; +; which allows the AND macro to generate better code. + + (help-begin + (lambda (old new) + (if (null? old) + (reverse! new) + (help-begin + (cdr old) + (cons + (let ((s (car old))) + (if (and (cdr old) ; leave last stmt alone + (not (atom? s)) + (eq? (car s) 'OR)) + (cons 'AND + (mapcar (lambda (a) (list 'NOT a)) + (cdr s))) + s)) + new))))) + + (exp-letrec + (lambda (x env) + (chk-length>= x x 3) + (chk-pairs x (letrec-pairs x)) + (let ((env (extend env (mapcar car (letrec-pairs x)))) + (body (make-contour (letrec-body-list x) env '()))) + (list 'LETREC + (exp-pairs (letrec-pairs x) '() env) + (expand body env))))) + + (exp-pairs + (lambda (old new env) + (if (null? old) + (reverse! new) + (let ((id (cdr (assq (caar old) env))) + (exp (fluid-let ((name (caar old))) + (expand (cadar old) env)))) + (exp-pairs (cdr old) + (cons (list id exp) new) + env))))) + + (exp-application + (lambda (form env) + (chk-length>= form form 1) + (let ((fn (car form)) + (args (cdr form))) + (cond ((pair? fn) + (let* ((exp (exp-args form '() env)) + (xfn (car exp))) + (cond ((or (atom? xfn) + (not (eq? (car xfn) 'LAMBDA))) + exp) + ((negative? (lambda-nargs xfn)) + (let ((id (pcs-make-id 'MULAMBDA))) ; must guarantee + `(LETREC ((,id ,xfn)) ; no "mulambda" in + (,id . ,(cdr exp))))) ; "function position" + ((=? (length args)(lambda-nargs xfn)) + exp) + (else + (syntax-error "Wrong number of arguments" form))))) + ((symbol? fn) + (let ((lex (assq fn env))) + (if lex + (cons (cdr lex)(exp-args args '() env)) + (apply-if + (lookup-primop fn integrate-global? + integrate-primitive?) + (lambda (info) + (cond ((integer? info) + (chk-length= form (cdr form) info) + (cons fn (exp-args (cdr form) '() env))) + ((pair? info) + ;; integrable definition + (exp-integrable form (cdr info) (cdr form) + env)) + (else + ;; VM primitive + (let ((form2 (info form))) + (if (equal? form form2) + (cons (car form) + (exp-args + (cdr form) '() env)) + (expand form2 env)))))) + (cons (make-global fn) + (exp-args args '() env)))))) + (else + (syntax-error "Invalid function name" fn)))))) + + (exp-args + (lambda (old new env) + (if (null? old) + (reverse! new) + (exp-args (cdr old) + (cons (expand (car old) env) new) + env)))) + + (exp-integrable + (lambda (form fn args env) + (letrec ((mismatch + (lambda (x y) + (cond ((null? x) (not (null? y))) + ((atom? x) #!false) + ((atom? y) #!true) + (else (mismatch (cdr x)(cdr y))))))) + (if (and (pair? fn) + (eq? (car fn) 'LAMBDA) + (pair? (cdr fn)) + (mismatch (cadr fn) args)) + (syntax-error "Wrong number of arguments" form) + (expand (cons fn args) env))))) + + (make-body + (lambda (lst) + (cond ((null? lst) ''()) + ((null? (cdr lst)) (car lst)) + (else (cons 'BEGIN lst))))) + + (extend + (lambda (env bvl) + ;; note: error checking done earlier + (cond (bvl + (let* ((var (car bvl)) + (new (pcs-make-id var)) + (rib (cons var new))) + (extend (cons rib env) + (cdr bvl)))) + (env + env) + (else ; distinguish `empty env' from `no env' + '((())))))) + + (lookup + (lambda (id env) + (apply-if (getprop id 'PCS*MACRO) + (lambda (mac) + (if (pair? mac) + (expand (cdr mac) env) ; alias + (syntax-error ; macro + "Macro name used as variable" id))) + (apply-if (assq id env) + (lambda (lex) (cdr lex)) ; lexical var + (let ((info (lookup-primop id + integrate-global? + integrate-primitive?))) + (cond ((or (null? info) + (integer? info)) + (make-global id)) + ((pair? info) + (expand (cdr info) env)) + (else + (expand (info id) env)))))))) + + (lookup-LHS + (lambda (id caller env) + (if (or (null? id) + (not (symbol? id)) + (getprop id 'PCS*MACRO)) ; macro or alias + (syntax-error (string-append "Invalid identifier for " caller ": ") id) + (let ((lex (assq id env))) + (cond (lex (cdr lex)) + ((and display-warnings? + (lookup-primop id integrate-global? + integrate-primitive?)) + (writeln + "[WARNING: modifying an `integrable' variable: " + id "]") + id) + (else id)))))) + + (lookup-primop + (lambda (id integrate-global? integrate-primitive?) + (and (symbol? id) + (let ((info (getprop id 'PCS*PRIMOP-HANDLER))) + (and info + (if (pair? info) integrate-global? integrate-primitive?) + info))))) + + (primitive? + (lambda (id env) + (and (not (getprop id 'PCS*MACRO)) + (not (assq id env)) + (let ((info (lookup-primop id #!false integrate-primitive?))) + (or (integer? info) + (closure? info)))))) + + (make-global + (lambda (id) + `(%%GET-GLOBAL%% (QUOTE ,id)))) + + ;;; data + + (integrate-global? pcs-integrate-integrables) + (integrate-primitive? pcs-integrate-primitives) + (integrate-T-and-NIL? pcs-integrate-T-and-NIL) + (display-warnings? pcs-display-warnings) + +;------! + ) + + (fluid-let ((name '())) ; default lambda "name" + (expand exp '()))))) + \ No newline at end of file diff --git a/newpcs/pnum2s.s b/newpcs/pnum2s.s new file mode 100644 index 0000000..5045e21 --- /dev/null +++ b/newpcs/pnum2s.s @@ -0,0 +1,395 @@ + +; -*- Mode: Lisp -*- Filename: pnum2s.s + +; Last Revision: 10-Feb-87 0900ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; NUMBER->STRING and INTEGER->STRING Routines (Mark Meyer) ; +; STRING->NUMBER (Terry Caudill) ; +; ; +;--------------------------------------------------------------------------; + +; Revision History: +; +; tc 02/10/87 included string->number routine +; + +(define string->number + (lambda (string exactness radix) + (if (not (or (eq? exactness 'E) (eq? exactness 'I))) + (error "STRING->NUMBER: Invalid exactness specifier " exactness) + (let ((s-radix '()) + (port '()) + (num '())) + (set! s-radix (apply-if (memq radix '(B O D X)) + (lambda (val) (symbol->string (car val))) + (error "STRING->NUMBER: Invalid radix " radix))) + (set! port (open-input-string (string-append "#" s-radix string))) + (set! num (read port)) + (if (not (number? num)) + (error "STRING->NUMBER: Can't convert string" + (string-append "#" s-radix string))) + (close-input-port port) + num)))) + +(define number->string) +(define integer->string) + +(letrec + ((form-%%squares%% + (lambda () + (mapc (lambda (x) + (let ((base (float (car x))) + (vec (cadr x))) + (do ((i (-1+ (vector-length vec)) (-1+ i))) + ((negative? i) 'OK) + (vector-set! vec i base) + (if (positive? i) (set! base (* base base)))))) + %%squares%%))) + + (%%squares%% + `((2 ,(make-vector 10)) (8 ,(make-vector 9)) + (10 ,(make-vector 9)) (16 ,(make-vector 8)))) + + + (scale + (lambda (flo base) + (if (null? (vector-ref (cadar %%squares%%) 0)) + (form-%%squares%%)) + (if (zero? flo) + (cons flo 0) + (let ((small (< flo 1.)) + (sqrvec (cadr (assq base %%squares%%)))) + (let ((scale 0) + (local (if small (/ flo) flo)) + (lim (vector-length sqrvec))) + (do ((i 0 (1+ i))) + ((= i lim) '()) + (set! scale (* 2 scale)) + (let ((sqr (vector-ref sqrvec i))) + (when (>= local sqr) + (set! scale (1+ scale)) + (set! local (/ local sqr))))) + (when small + (set! scale (- scale)) + (set! local (/ local)) + (when (< local 1.) + (set! scale (-1+ scale)) + (set! local (* local base)))) + (cons local scale)))))) + + (int->str + (lambda (n base) + (letrec + ((i->s + (lambda (n) + (if (zero? n) + "" + (let ((dig (remainder n base)) + (rest (quotient n base))) + (string-append + (i->s rest) + (make-string 1 (integer->char + (+ dig (if (> dig 9) 55 48)))))))))) + (cond ((negative? n) + (string-append "-" (int->str (- n) base))) + ((zero? n) (make-string 1 #\0)) + (else (i->s n)))))) + + (num->str + (lambda (num format) + (define bad-format + (lambda () + (error "NUMBER->STRING: Invalid format specification" format))) + (if (not (number? num)) + (error "NUMBER->STRING: Invalid argument" num)) + (if (atom? format) (bad-format)) + (letrec + ((absnum (abs num)) + (sign (if (negative? num) "-" "")) + (base 10) + (radix "") + (exact (integer? num)) + (exactness "") + (result "") + (sigfigs ()) + (factor ()) + (half-digit ()) + (highest-digit ()) + (numtype (car format)) + (formargs (cdr format)) + (numscale ()) + (numnorm ()) + (n ()) + (m ()) + (result-len ()) + (set-mods + (lambda (l) + (cond ((null? l) #!true) + ((atom? l) ()) + ((not (set-mods (cdr l))) ()) + (else + (let ((mod (car l))) + (if (pair? mod) + (case (car mod) + (radix + (if (null? (cdr mod)) + () + (begin + (set! base + (cadr (assq (cadr mod) + '((B 2) (O 8) + (D 10) (X 16))))) + (if base + (set! radix + (let ((express + (caddr mod))) + (cond ((or (eq? express 'E) + (null? express)) + (cadr (assq base + '((2 "#b") + (8 "#o") + (10 "#d") + (16 "#x") + )))) + ((eq? express 'S) + "") + (else ()))))) + (and base radix)))) + (exactness + (case (cadr mod) + (e (set! exactness (if exact "#E" "#I"))) + (s (set! exactness "")) + (else ()))) + (else ())) + ())))))) + (argcheck + (lambda (arg) + (or (number? arg) (eq? arg 'H)))) ; `Heuristic' + (check-args + (lambda (num-of-args) + (if (case num-of-args + (0 (set-mods formargs)) + (1 + (set-mods + (if (argcheck (car formargs)) + (begin + (set! n (car formargs)) + (cdr formargs)) + formargs))) + (2 + (set-mods + (if (argcheck (car formargs)) + (begin + (set! n (car formargs)) + (if (argcheck (cadr formargs)) + (begin + (set! m (cadr formargs)) + (cddr formargs)) + (cdr formargs))) + formargs)))) + (begin + (set! sigfigs + (cadr (assq base + '((2 53) (8 17) (10 15) (16 13))))) + (set! factor (float (expt base (-1+ sigfigs)))) + (set! half-digit + (integer->char (+ 48 (quotient base 2)))) + (set! highest-digit + (if (= base 16) + #\f + (integer->char (+ 48 (-1+ base))))) + #!true) + (bad-format)))) + (string-round + (lambda (s place) + (cond ((< place 1) s) + ((<= (string-length s) place) s) + ((charchar + (1+ (char->integer c)))))))) + (string-set! s i #\0)) + (when (char=? (string-ref s 0) #\0) + (if (number? numscale) + (set! numscale (1+ numscale))) + (substring-move-right! + s 0 (-1+ (string-length s)) s 1) + (string-set! s 0 #\1)) + s)))) + (flag-insignificants + (lambda (s places c) + (let ((len (string-length s))) + (if (> len places) + (substring-fill! s places len c)) + s))) + (form-result + (lambda (flo) + (if (not (number? flo)) + (error "NUMBER->STRING: number too large for format" num)) + (set! flo (round flo)) + (when (and (member numtype '(FLO SCI)) + (>= flo + (if (number? n) + (expt base n) + (* factor base)))) + (set! numscale (1+ numscale)) + (set! flo (quotient flo base))) + (set! result (int->str flo base)) + (set! result (string-round result sigfigs)) + (flag-insignificants + result + sigfigs + (if (integer? num) #\0 #\#)))) + (set-result-len + (lambda () + (set! result-len (string-length result)))) + (add-leading-zeros + (lambda (n) + (set-result-len) + (set! result + (cond ((string=? result "0") (make-string n #\0)) + ((>= n result-len) + (string-append + (make-string (- n result-len) #\0) + result)) + (else result))))) + (insert-point + (lambda (place) + (set! result + (string-append + (substring result 0 place) + "." + (if (and (float? num) + (= place result-len)) + "0" + (substring result place result-len)))))) + (scale-absnum + (lambda () + (let ((x (scale absnum base))) + (set! numscale (cdr x)) + (set! numnorm (car x))))) + (kill-trailing-zeros + (lambda (lim) + (do ((i (-1+ (string-length result)) (-1+ i))) + ((or (< i lim) + (not (char=? (string-ref result i) #\0))) + (set! result (substring result 0 (1+ i)))) + '()))) + (float-integer + (lambda () + (if (integer? absnum) + (set! absnum (float absnum))) + (if (not (number? absnum)) + (error + "NUMBER->STRING: integer too large for float conversion" + num)))) + (return-result + (lambda () + (if (string=? result ".") (set! result "0.")) + (string-append radix exactness sign result)))) + (case numtype + (int + (check-args 0) + (if (integer? absnum) + (set! result (int->str absnum base)) + (form-result absnum)) + (return-result)) + (fix + (check-args 1) + (if (null? n) (set! n sigfigs)) + (if (or (eq? n 'H) (negative? n)) + (bad-format)) + (float-integer) + (form-result (* absnum (expt base n))) + (add-leading-zeros n) + (set-result-len) + (insert-point (- result-len n)) + (return-result)) + (flo + (check-args 1) + (if (null? n) (set! n sigfigs)) + (if (and (not (eq? n 'H)) (not (positive? n))) + (bad-format)) + (float-integer) + (scale-absnum) + (if (or (>= numscale sigfigs) (< numscale -1)) + (num->str num (cons 'SCI formargs)) + (begin + (if (number? n) + (form-result (* numnorm (expt base (-1+ n)))) + (begin + (form-result (* numnorm factor)) + (kill-trailing-zeros (1+ numscale)))) + (set-result-len) + (when (<= result-len numscale) + (set! result + (string-append result + (make-string + (- (1+ numscale) result-len) #\0))) + (set-result-len)) + (insert-point (1+ numscale)) + (return-result)))) + (sci + (check-args 2) + (if (or (eq? m 'H) + (and (number? m) (eq? n 'H))) + (bad-format)) + (if (null? n) (set! n sigfigs)) + (if (and (number? n) (null? m)) (set! m (-1+ n))) + (if (and (number? n) + (or (not (positive? n)) (negative? m) (< n m))) + (bad-format)) + (float-integer) + (scale-absnum) + (if (number? n) + (begin + (form-result (* numnorm (expt base (-1+ n)))) + (set! m (- n m))) + (begin + (form-result (* numnorm factor)) + (set! m 1) + (kill-trailing-zeros m))) + (set-result-len) + (if (< m result-len) (insert-point m)) + (set! result + (string-append + result + (if (= base 16) "L" "E") + (int->str (1+ (- numscale m)) 10))) + (return-result)) + (heur + (check-args 0) + (if (integer? absnum) + (num->str num (cons 'INT formargs)) + (num->str num + (list* (if (or (= absnum 0.0) + (and (>= absnum 1.0e-3) + (< absnum 1.0e7))) + 'FLO + 'SCI) + 'H + formargs)))) + (else (bad-format))))))) + (set! number->string ; number->string + (lambda (n f) + (num->str n f))) + (set! integer->string ; integer->string + (lambda (n base) + (int->str n base)))) + \ No newline at end of file diff --git a/newpcs/popcodes.s b/newpcs/popcodes.s new file mode 100644 index 0000000..f24a0c3 --- /dev/null +++ b/newpcs/popcodes.s @@ -0,0 +1,707 @@ + +; -*- Mode: Lisp -*- Filename: popcodes.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985, 1987 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Primitive Functions and Opcodes ; +; ; +; tc 2/10/87 READ-STRING opcode added ; +; rb 3/20/87 %XESC opcode added ; +; rb 4/ 1/87 pcs-primop-+, -* modified; no error was being signalled ; +; for a single non-numeric argument to either + or * since ; +; pcs-primop-std-n2 assumes a unary arg is the operator's ; +; identity element and removes the operator; so, the ; +; arg was never type-checked since the operator's handler ; +; never got called; now force unarys to binarys to keep ; +; the operator ; +; tc 4/13/87 make-string primop handler changed to handle optional ; +; 2nd argument ; +; ; +;--------------------------------------------------------------------------; + + +(define pcs-define-primop + (lambda (op handler) + (putprop op handler 'pcs*primop-handler))) + + +(define (pcs-primop-std-n2 form) ; n-ary to binary, left associative + (if (atom? form) + `(%%get-global%% (quote ,form)) ; funarg use + (begin + (pcs-chk-length>= form form 2) + (cond ((null? (cddr form)) ; unary? + (cadr form)) ; --> identity + ((null? (cdddr form)) + form) ; binary + (else + (let ((op (car form)) + (a (cadr form)) + (b (caddr form)) + (rest (cdddr form))) + (pcs-primop-std-n2 + `(,op (,op ,a ,b) . ,rest)))))))) + + +(define (pcs-primop-append* form) ; for append, append!, string-append + (if (atom? form) + `(%%get-global%% (quote ,form)) ; funarg use + (let ((op (car form))) + (pcs-chk-length>= form form 1) + (cond ((null? (cdr form)) ; no args? + (if (eq? op 'STRING-APPEND) + ''"" + ''())) + ((null? (cddr form)) ; one arg? + (if (eq? op 'STRING-APPEND) + `(STRING-APPEND ,(cadr form) '"") + (cadr form))) + ((null? (cdddr form)) ; two args? + (case op + ((APPEND) `(%APPEND . ,(cdr form))) + ((APPEND!) form) + (else + `(let ((%00000 ,(cadr form)) + (%00001 ,(caddr form))) + (%STRING-APPEND %00000 0 (STRING-LENGTH %00000) + '() + %00001 0 (STRING-LENGTH %00001)))))) + ((and (null? (cddddr form)) + (eq? op 'STRING-APPEND)) ; 3 args + `(let ((%00000 ,(cadr form)) + (%00001 ,(caddr form)) + (%00002 ,(cadddr form))) + (%STRING-APPEND %00000 0 (STRING-LENGTH %00000) + %00001 + %00002 0 (STRING-LENGTH %00002)))) + (else + (let ((a (cadr form)) + (b (caddr form)) + (rest (cdddr form))) + (pcs-primop-append* + `(,op ,a (,op ,b . ,rest))))))))) + + +(define pcs-primop-+ ; "+" handler + (lambda (form) + (if (and (not (atom? form)) + (null? (cdr form))) + 0 + (if (and (not (atom? form)) + (null? (cddr form))) + `(+ 0 ,(cadr form)) + (pcs-primop-std-n2 form))))) + + +(define pcs-primop-- ; "-" handler + (lambda (form) + (cond ((and (not (atom? form)) + (not (atom? (cdr form))) + (null? (cddr form))) + `(minus ,(cadr form))) + (t (pcs-primop-std-n2 form))))) + + +(define pcs-primop-* ; "*" handler + (lambda (form) + (if (and (not (atom? form)) + (null? (cdr form))) + 1 + (if (and (not (atom? form)) + (null? (cddr form))) + `(* 1 ,(cadr form)) + (pcs-primop-std-n2 form))))) + + +(define pcs-primop-/ ; "/" handler + (lambda (form) + (cond ((and (not (atom? form)) + (not (atom? (cdr form))) + (null? (cddr form))) + `(/ '1 ,(cadr form))) + (t (pcs-primop-std-n2 form))))) + + +(define (pcs-primop-vector form) ; "vector" handler + (cond ((atom? form) + `(%%get-global%% (quote vector))) + (else + `(list->vector (list . ,(cdr form)))))) + + +(define (pcs-primop-list form) ; "list" handler + (cond ((atom? form) + `(%%get-global%% (quote list))) + ((atom? (cdr form)) ; (list) + ''()) + ((atom? (cddr form)) ; (list a) + form) + ((atom? (cdddr form)) + (cons '%list2 (cdr form))) + (else + (let ((rest (pcs-primop-list (cons 'list (cddr form))))) + `(cons ,(cadr form) ,rest))))) + + +(define (pcs-primop-list* form) ; "list*" handler + (cond ((atom? form) + `(%%get-global%% (quote list*))) + ((atom? (cdr form)) ; (list*) + ''()) + ((atom? (cddr form)) ; (list* a) + (cadr form)) + (else + (let ((rest (pcs-primop-list* (cons 'list* (cddr form))))) + `(cons ,(cadr form) ,rest))))) + + +(define pcs-primop-make-vector ; "make-vector" handler + (lambda (form) + (cond ((atom? form) + `(%%get-global%% (quote ,form))) ; funarg use + ((and (not (atom? (cdr form))) ; unary? + (null? (cddr form))) + form) + ((and (not (atom? (cdr form))) ; binary? + (not (atom? (cddr form))) + (null? (cdddr form))) + `(let ((%00000 (make-vector ,(cadr form)))) + (begin (vector-fill! %00000 ,(caddr form)) + %00000))) + (else + (pcs-chk-length= form form 3))))) + + +(define pcs-primop-io-1 ; optional PORT arg + (lambda (form) + (cond ((atom? form) + `(%%get-global%% (quote ,form))) ; funarg use + ((null? (cdr form)) + `(,(car form) '())) ; add null port + ((and (not (atom? (cdr form))) + (null? (cddr form))) + form) ; PORT supplied + (else + (pcs-chk-length= form form 2))))) + +; +; Note that make-string uses the following primop definition to take +; care of its optional second argument. +; + +(define pcs-primop-io-2 ; optional 2nd PORT arg + (lambda (form) + (cond ((atom? form) + `(%%get-global%% (quote ,form))) ; funarg use + ((and (not (atom? (cdr form))) + (null? (cddr form))) ; add null port + `(,(car form) ,(cadr form) '())) + ((and (not (atom? (cdr form))) + (not (atom? (cddr form))) + (null? (cdddr form))) + form) ; PORT supplied + (else + (pcs-chk-length= form form 3))))) + +;;; -------------------------------------------------------------------- + + +;;; !! NOTE !! + +;;; Each primitive operation defined with PCS-DEFINE-PRIMOP must also +;;; be represented at runtime as a closure object in case the name is +;;; used as a "funarg." The error handler can auto-create such +;;; closures when both PCS*PRIMOP-HANDLER and PCS*OPCODE properties are +;;; integers. Others must have such closures defined explicitly. Many +;;; of them are defined in the PCS source file PFUNARG.S. + + +;;; -------------------------------------------------------------------- + + +(begin + (pcs-define-primop '%%bind-fluid%% 2) + (pcs-define-primop '%%car 1) + (pcs-define-primop '%%cdr 1) + (pcs-define-primop '%%def-global%% 2) + (pcs-define-primop '%%execute 1) + (pcs-define-primop '%%fasl 1) + (pcs-define-primop '%%fluid-bound?%% 1) + (pcs-define-primop '%%get-fluid%% 1) + (pcs-define-primop '%%get-global%% 1) + (pcs-define-primop '%%get-scoops%% 1) + (pcs-define-primop '%%set-fluid%% 2) + (pcs-define-primop '%%set-global%% 2) + (pcs-define-primop '%%set-scoops%% 2) + (pcs-define-primop '%%unbind-fluid%% 1) + (pcs-define-primop '%append 2) + (pcs-define-primop '%apply 2) + (pcs-define-primop '%begin-debug 0) + (pcs-define-primop '%call/cc 1) + (pcs-define-primop '%car 1) + (pcs-define-primop '%cdr 1) + (pcs-define-primop '%clear-registers 0) + (pcs-define-primop '%clear-window 1) + (pcs-define-primop '%close-port 1) + (pcs-define-primop '%compact-memory 0) + (pcs-define-primop '%define 3) + (pcs-define-primop '%env-lu 2) + (pcs-define-primop '%esc1 1) + (pcs-define-primop '%esc2 2) + (pcs-define-primop '%esc3 3) + (pcs-define-primop '%esc4 4) + (pcs-define-primop '%esc5 5) + (pcs-define-primop '%esc6 6) + (pcs-define-primop '%esc7 7) + (pcs-define-primop '%xesc (lambda (form) form)) + (pcs-define-primop '%garbage-collect 0) + (pcs-define-primop '%graphics 7) + (pcs-define-primop '%halt 0) + (pcs-define-primop '%internal-time 0) + (pcs-define-primop '%list2 2) + (pcs-define-primop '%logxor 2) + (pcs-define-primop '%logand 2) + (pcs-define-primop '%logior 2) + (pcs-define-primop '%make-window 1) + (pcs-define-primop '%open-port 2) + (pcs-define-primop '%random 0) + (pcs-define-primop '%reify 2) + (pcs-define-primop '%reify! 3) + (pcs-define-primop '%reify-port 2) + (pcs-define-primop '%reify-port! 3) + (pcs-define-primop '%reify-stack 1) + (pcs-define-primop '%reify-stack! 2) + (pcs-define-primop '%restore-window 2) + (pcs-define-primop '%save-window 1) + (pcs-define-primop '%set-global-environment 1) + (pcs-define-primop '%sfpos 3) ; set-file-position! + (pcs-define-primop '%start-timer 1) + (pcs-define-primop '%stop-timer 0) + (pcs-define-primop '%string-append 7) + (pcs-define-primop '%substring-display 5) + (pcs-define-primop '%transcript 1) +) + +(begin + (pcs-define-primop '* pcs-primop-*) + (pcs-define-primop '+ pcs-primop-+) + (pcs-define-primop '- pcs-primop--) + (pcs-define-primop '/ pcs-primop-/ ) + (pcs-define-primop '< 2) + (pcs-define-primop '<= 2) + (pcs-define-primop '<=? 2) + (pcs-define-primop '<> 2) + (pcs-define-primop '<>? 2) + (pcs-define-primop ' 2) + (pcs-define-primop '>= 2) + (pcs-define-primop '>=? 2) + (pcs-define-primop '>? 2) + (pcs-define-primop 'abs 1) + (pcs-define-primop 'append pcs-primop-append*) + (pcs-define-primop 'append! pcs-primop-append*) + (pcs-define-primop 'assoc 2) + (pcs-define-primop 'assq 2) + (pcs-define-primop 'assv 2) + (pcs-define-primop 'atom? 1) + (pcs-define-primop 'caaar 1) + (pcs-define-primop 'caadr 1) + (pcs-define-primop 'caar 1) + (pcs-define-primop 'cadar 1) + (pcs-define-primop 'cadddr 1) + (pcs-define-primop 'caddr 1) + (pcs-define-primop 'cadr 1) + (pcs-define-primop 'car 1) + (pcs-define-primop 'cdaar 1) + (pcs-define-primop 'cdadr 1) + (pcs-define-primop 'cdar 1) + (pcs-define-primop 'cddar 1) + (pcs-define-primop 'cdddr 1) + (pcs-define-primop 'cddr 1) + (pcs-define-primop 'cdr 1) + (pcs-define-primop 'ceiling 1) + (pcs-define-primop 'char->integer 1) + (pcs-define-primop 'char-cichar 1) + (pcs-define-primop 'integer? 1) + (pcs-define-primop 'last-pair 1) + (pcs-define-primop 'length 1) + (pcs-define-primop 'list pcs-primop-list) + (pcs-define-primop 'list* pcs-primop-list*) + (pcs-define-primop 'list-tail 2) + (pcs-define-primop 'make-packed-vector 3) + (pcs-define-primop 'make-string pcs-primop-io-2) ; handle optional 2nd arg + (pcs-define-primop 'make-vector pcs-primop-make-vector) + (pcs-define-primop 'max pcs-primop-std-n2) + (pcs-define-primop 'member 2) + (pcs-define-primop 'memq 2) + (pcs-define-primop 'memv 2) + (pcs-define-primop 'min pcs-primop-std-n2) + (pcs-define-primop 'minus 1) + (pcs-define-primop 'negative? 1) + (pcs-define-primop 'newline pcs-primop-io-1) + (pcs-define-primop 'not 1) + (pcs-define-primop 'number? 1) + (pcs-define-primop 'object-hash 1) + (pcs-define-primop 'object-unhash 1) + (pcs-define-primop 'odd? 1) + (pcs-define-primop 'pair? 1) + (pcs-define-primop 'port? 1) + (pcs-define-primop 'positive? 1) + (pcs-define-primop 'prin1 pcs-primop-io-2) + (pcs-define-primop 'princ pcs-primop-io-2) + (pcs-define-primop 'print pcs-primop-io-2) + (pcs-define-primop 'print-length 1) + (pcs-define-primop 'proc? 1) + (pcs-define-primop 'proplist 1) + (pcs-define-primop 'putprop 3) + (pcs-define-primop 'quotient 2) + (pcs-define-primop 'rational? 1) + (pcs-define-primop 'read-line pcs-primop-io-1) + (pcs-define-primop 'read-atom pcs-primop-io-1) + (pcs-define-primop 'read-char pcs-primop-io-1) + (pcs-define-primop 'real? 1) + (pcs-define-primop 'remainder 2) + (pcs-define-primop 'remprop 2) + (pcs-define-primop 'reset 0) + (pcs-define-primop 'reverse! 1) + (pcs-define-primop 'round 1) + (pcs-define-primop 'scheme-reset 0) + (pcs-define-primop 'set-car! 2) + (pcs-define-primop 'set-cdr! 2) + (pcs-define-primop 'string->symbol 1) + (pcs-define-primop 'string->uninterned-symbol 1) + (pcs-define-primop 'string-append pcs-primop-append*) + (pcs-define-primop 'string-fill! 2) + (pcs-define-primop 'string-length 1) + (pcs-define-primop 'string-ref 2) + (pcs-define-primop 'string-set! 3) + (pcs-define-primop 'string? 1) + (pcs-define-primop 'substring 3) + (pcs-define-primop 'substring-find-next-char-in-set 4) + (pcs-define-primop 'substring-find-previous-char-in-set 4) + (pcs-define-primop 'symbol->string 1) + (pcs-define-primop 'symbol? 1) + (pcs-define-primop 'the-environment 0) + (pcs-define-primop '%make-hashed-environment 0) + (pcs-define-primop 'truncate 1) + (pcs-define-primop 'vector pcs-primop-vector) + (pcs-define-primop 'vector-fill! 2) + (pcs-define-primop 'vector-length 1) + (pcs-define-primop 'vector-ref 2) + (pcs-define-primop 'vector-set! 3) + (pcs-define-primop 'vector? 1) + (pcs-define-primop 'window-save-contents 1) + (pcs-define-primop 'window-restore-contents 2) + (pcs-define-primop 'write pcs-primop-io-2) + (pcs-define-primop 'write-char pcs-primop-io-2) + (pcs-define-primop 'zero? 1) + ) + + +;;; -------------------------------------------------------------------- + + +(define pcs-define-opcode ; !! NOTE !! + (lambda (op opcode) ; negative values mark + (putprop op opcode 'pcs*opcode))) ; side-effecting operations + +;;; -- opcode assignments -- + +(begin + (pcs-define-opcode '%%car 064) ; (%%car nil) => nil + (pcs-define-opcode '%%cdr 065) ; (%%cdr nil) => nil + (pcs-define-opcode '%%fasl -191) + (pcs-define-opcode '%*imm 084) + (pcs-define-opcode '%+imm 081) + (pcs-define-opcode '%/imm 086) + (pcs-define-opcode '%append 113) + (pcs-define-opcode '%apply -056) + (pcs-define-opcode '%call/cc -054) + (pcs-define-opcode '%car 089) ; (%car nil) => #!unbound + (pcs-define-opcode '%cdr 090) ; (%cdr nil) => #!unbound + (pcs-define-opcode '%clear-window -211) + (pcs-define-opcode '%close-port -177) + (pcs-define-opcode '%define -220) + (pcs-define-opcode '%env-lu 219) + (pcs-define-opcode '%esc1 -232) + (pcs-define-opcode '%esc2 -233) + (pcs-define-opcode '%esc3 -234) + (pcs-define-opcode '%esc4 -235) + (pcs-define-opcode '%esc5 -236) + (pcs-define-opcode '%esc6 -237) + (pcs-define-opcode '%esc7 -238) + (pcs-define-opcode '%xesc -239) + (pcs-define-opcode '%graphics -215) + (pcs-define-opcode '%halt -248) + (pcs-define-opcode '%list2 120) + (pcs-define-opcode '%logxor 125) + (pcs-define-opcode '%logand 126) + (pcs-define-opcode '%logior 127) + (pcs-define-opcode '%make-window -208) + (pcs-define-opcode '%open-port -176) + (pcs-define-opcode '%random -091) + (pcs-define-opcode '%reify 216) + (pcs-define-opcode '%reify! -226) + (pcs-define-opcode '%reify-port 210) + (pcs-define-opcode '%reify-port! -209) + (pcs-define-opcode '%reify-stack 229) + (pcs-define-opcode '%reify-stack! -230) + (pcs-define-opcode '%restore-window -213) + (pcs-define-opcode '%save-window -212) + (pcs-define-opcode '%set-global-environment -225) + (pcs-define-opcode '%sfpos -231) ; set-file-position! + (pcs-define-opcode '%start-timer -174) + (pcs-define-opcode '%stop-timer -175) + (pcs-define-opcode '%string-append 214) + (pcs-define-opcode '%substring-display -172) + (pcs-define-opcode '%transcript -189) +) +(begin + (pcs-define-opcode '* 083) + (pcs-define-opcode '+ 080) + (pcs-define-opcode '- 082) + (pcs-define-opcode '/ 085) + (pcs-define-opcode '< 092) + (pcs-define-opcode '<= 093) + (pcs-define-opcode '<=? 093) + (pcs-define-opcode '<> 097) + (pcs-define-opcode '<>? 097) + (pcs-define-opcode ' 095) + (pcs-define-opcode '>= 096) + (pcs-define-opcode '>=? 096) + (pcs-define-opcode '>? 095) + (pcs-define-opcode 'abs 149) + (pcs-define-opcode 'append! -112) + (pcs-define-opcode 'assoc 110) + (pcs-define-opcode 'assq 108) + (pcs-define-opcode 'assv 109) + (pcs-define-opcode 'atom? 128) + (pcs-define-opcode 'caaar 070) + (pcs-define-opcode 'caadr 071) + (pcs-define-opcode 'caar 066) + (pcs-define-opcode 'cadar 072) + (pcs-define-opcode 'cadddr 078) + (pcs-define-opcode 'caddr 073) + (pcs-define-opcode 'cadr 067) + (pcs-define-opcode 'car 064) ; same as %%car + (pcs-define-opcode 'cdaar 074) + (pcs-define-opcode 'cdadr 075) + (pcs-define-opcode 'cdar 068) + (pcs-define-opcode 'cddar 076) + (pcs-define-opcode 'cdddr 077) + (pcs-define-opcode 'cddr 069) + (pcs-define-opcode 'cdr 065) ; same as %%cdr + (pcs-define-opcode 'ceiling 153) + (pcs-define-opcode 'char->integer 161) + (pcs-define-opcode 'char-cichar 160) + (pcs-define-opcode 'integer? 135) + (pcs-define-opcode 'last-pair 166) + (pcs-define-opcode 'length 165) + (pcs-define-opcode 'list 111) + (pcs-define-opcode 'list-tail 122) + (pcs-define-opcode 'make-packed-vector 171) + (pcs-define-opcode 'make-string 201) + (pcs-define-opcode 'make-vector 168) + (pcs-define-opcode 'max 098) + (pcs-define-opcode 'member 105) + (pcs-define-opcode 'memq 103) + (pcs-define-opcode 'memv 104) + (pcs-define-opcode 'min 099) + (pcs-define-opcode 'minus 151) + (pcs-define-opcode 'negative? 147) + (pcs-define-opcode 'newline -181) + (pcs-define-opcode 'not 136) + (pcs-define-opcode 'number? 137) + (pcs-define-opcode 'object-hash -227) + (pcs-define-opcode 'object-unhash 228) + (pcs-define-opcode 'odd? 138) + (pcs-define-opcode 'pair? 139) + (pcs-define-opcode 'port? 140) + (pcs-define-opcode 'positive? 148) + (pcs-define-opcode 'prin1 -178) + (pcs-define-opcode 'princ -179) + (pcs-define-opcode 'print -180) + (pcs-define-opcode 'print-length 184) + (pcs-define-opcode 'proc? 141) + (pcs-define-opcode 'proplist 118) + (pcs-define-opcode 'putprop -117) + (pcs-define-opcode 'quotient 087) + (pcs-define-opcode 'rational? 135) ; same as INTEGER? + (pcs-define-opcode 'read-line -186) + (pcs-define-opcode 'read-atom -187) + (pcs-define-opcode 'read-char -188) + (pcs-define-opcode 'real? 137) ; same as NUMBER? + (pcs-define-opcode 'remainder 088) + (pcs-define-opcode 'remprop -119) + (pcs-define-opcode 'reset -251) + (pcs-define-opcode 'reverse! -106) + (pcs-define-opcode 'round 155) + (pcs-define-opcode 'scheme-reset -252) + (pcs-define-opcode 'set-car! -020) + (pcs-define-opcode 'set-cdr! -021) + (pcs-define-opcode 'string->symbol 203) + (pcs-define-opcode 'string->uninterned-symbol 204) + (pcs-define-opcode 'string-fill! -202) + (pcs-define-opcode 'string-length 198) + (pcs-define-opcode 'string-ref 199) + (pcs-define-opcode 'string-set! -200) + (pcs-define-opcode 'string? 143) + (pcs-define-opcode 'substring 167) + (pcs-define-opcode 'substring-find-next-char-in-set 206) + (pcs-define-opcode 'substring-find-previous-char-in-set 207) + (pcs-define-opcode 'symbol->string 205) + (pcs-define-opcode 'symbol? 144) + (pcs-define-opcode 'the-environment 217) + (pcs-define-opcode '%make-hashed-environment 62) + (pcs-define-opcode 'truncate 154) + (pcs-define-opcode 'vector-fill! -170) + (pcs-define-opcode 'vector-length 169) + (pcs-define-opcode 'vector-ref 011) + (pcs-define-opcode 'vector-set! -019) + (pcs-define-opcode 'vector? 145) + (pcs-define-opcode 'window-save-contents -212) + (pcs-define-opcode 'window-restore-contents -213) + (pcs-define-opcode 'write -178) + (pcs-define-opcode 'write-char -179) + (pcs-define-opcode 'zero? 146) + ) +;;; -------------------------------------------------------------------- + +(begin + (pcs-define-opcode 'LOAD 000) + (pcs-define-opcode 'LOAD-CONSTANT 001) + (pcs-define-opcode 'LOAD-IMMEDIATE 002) + (pcs-define-opcode 'LOAD-LOCAL 004) + (pcs-define-opcode 'LOAD-LEX 005) + (pcs-define-opcode 'LOAD-ENV 006) + (pcs-define-opcode 'LOAD-GLOBAL 007) + (pcs-define-opcode 'LOAD-FLUID 008) + + (pcs-define-opcode 'STORE-LOCAL -012) + (pcs-define-opcode 'STORE-LEX -013) + (pcs-define-opcode 'STORE-ENV -014) + (pcs-define-opcode 'STORE-GLOBAL -015) + (pcs-define-opcode 'STORE-GLOBAL-DEF -031) + (pcs-define-opcode 'STORE-FLUID -016) + + (pcs-define-opcode 'POP -024) + (pcs-define-opcode 'PUSH -025) + (pcs-define-opcode 'DROP -026) + (pcs-define-opcode 'DROP-ENV -061) + (pcs-define-opcode 'PUSH-ENV -221) + (pcs-define-opcode 'BIND-FLUID -029) + (pcs-define-opcode 'UNBIND-FLUIDS -030) + (pcs-define-opcode '%%fluid-bound?%% 134) + + (pcs-define-opcode 'J_S -032) + (pcs-define-opcode 'JN_S -034) + (pcs-define-opcode 'JNN_S -036) + (pcs-define-opcode 'JA_S -038) + (pcs-define-opcode 'JNA_S -040) + (pcs-define-opcode 'JE_S -042) + (pcs-define-opcode 'JNE_S -044) + + (pcs-define-opcode 'J_L -033) + (pcs-define-opcode 'JN_L -035) + (pcs-define-opcode 'JNN_L -037) + (pcs-define-opcode 'JA_L -039) + (pcs-define-opcode 'JNA_L -041) + (pcs-define-opcode 'JE_L -043) + (pcs-define-opcode 'JNE_L -045) + + (pcs-define-opcode 'CALL -048) + (pcs-define-opcode 'CALL-TR -049) + (pcs-define-opcode 'CCC -050) + (pcs-define-opcode 'CCC-TR -051) + (pcs-define-opcode 'CALL-CLOSURE -052) + (pcs-define-opcode 'CALL-CLOSURE-TR -053) + (pcs-define-opcode 'CCC-CLOSED -054) + (pcs-define-opcode 'CCC-CLOSED-TR -055) + (pcs-define-opcode 'APPLY-CLOSURE -056) + (pcs-define-opcode 'APPLY-CLOSURE-TR -057) + + (pcs-define-opcode 'EXIT -059) + (pcs-define-opcode 'CLOSE -060) + + (pcs-define-opcode '%begin-debug -255) + (pcs-define-opcode '%clear-registers -253) + (pcs-define-opcode '%compact-memory -247) + (pcs-define-opcode '%%execute -058) + (pcs-define-opcode '%garbage-collect -249) + (pcs-define-opcode '%internal-time 250) + ) +;;; -------------------------------------------------------------------- + +(begin + (putprop '%begin-debug #!true 'pcs*nilargop) ; no source or dest + (putprop '%clear-registers #!true 'pcs*nilargop) ; no source or dest + (putprop '%compact-memory #!true 'pcs*nilargop) ; no source or dest + (putprop '%garbage-collect #!true 'pcs*nilargop) ; no source or dest + (putprop '%halt #!true 'pcs*nilargop) ; no source or dest + (putprop 'reset #!true 'pcs*nilargop) ; no source or dest + (putprop 'scheme-reset #!true 'pcs*nilargop) ; no source or dest + ) +;;; -------------------------------------------------------------------- + +(begin ; collect garbage + (%clear-registers) + (%compact-memory)) + +;;; -------------------------------------------------------------------- + \ No newline at end of file diff --git a/newpcs/pp.s b/newpcs/pp.s new file mode 100644 index 0000000..2f44552 --- /dev/null +++ b/newpcs/pp.s @@ -0,0 +1,542 @@ + +; -*- Mode: Lisp -*- Filename: pp.s + +; Last Revision: 29-August-85 1600ct + +;--------------------------------------------------------------------------; +; ; +; SCHEME 84 -- PCS Compiler -- July 1984 ; +; ; +; David Bartley ; +; ; +; PrettyPrinter ; +; ; +;--------------------------------------------------------------------------; + + +(define pp ; PP + (lambda (exp . args) + (let ((port (car args)) + (margin (or (cadr args) 72))) + (fluid-let + ((output-port + (cond ((null? port) (fluid output-port)) + ((port? port) port) + ((string? port) + (let ((p (open-output-file port))) + (set-line-length! (max margin (line-length p)) p) + p)) + (else 'CONSOLE)))) + (%pretty-printer exp + (min margin (line-length (fluid output-port)))) + (when (string? port) + (close-output-port (fluid output-port))) + *the-non-printing-object*)))) + + +(define %pp-me ; %PP-ME + (lambda (e) + (let ((m (and (pair? e) + (getprop (car e) 'PCS*MACRO)))) + (cond ((null? m) + e) + ((pair? m) ; alias + (cons (cdr m)(cdr e))) + (else ; macro + (pp (m e))))))) + + +(syntax (%pp-set-pattern id pat) ; %PP-SET-PATTERN + (PUTPROP id pat '%PRETTY-PRINTER-PATTERN)) + + +(syntax (%pp-get-pattern id) ; %PP-GET-PATTERN + (GETPROP id '%PRETTY-PRINTER-PATTERN)) + + +;;; +;;; Pretty Printer Pattern Definitions +;;; + +(begin + (let ((pattern '(KEY . (2 . V-TAIL)))) ; BEGIN style + (%pp-set-pattern 'BEGIN pattern) + (%pp-set-pattern 'BEGIN0 pattern) + (%pp-set-pattern 'SEQUENCE pattern)) + + (let ((pattern '(NEAT (() . EXP) . (2 . V-TAIL)))) ; DEFINE style + (%pp-set-pattern 'ALIAS pattern) + (%pp-set-pattern 'ACCESS pattern) + (%pp-set-pattern 'APPLY-IF pattern) + (%pp-set-pattern 'DEFINE pattern) + (%pp-set-pattern 'DEFINE-INTEGRABLE + pattern) + (%pp-set-pattern 'MACRO pattern) + (%pp-set-pattern 'REC pattern) + (%pp-set-pattern 'SET-FLUID! pattern) + (%pp-set-pattern 'SYNTAX pattern)) + + (let ((pattern '(KEY (() . BVL) . (2 . V-TAIL)))) ; LAMBDA style + (%pp-set-pattern 'LAMBDA pattern) + (%pp-set-pattern 'FLUID-LAMBDA pattern) + (%pp-set-pattern 'NAMED-LAMBDA pattern)) + + (let ((pattern '(KEY (3 . TUPLES) . (2 . V-TAIL)))) ; LETREC style + (%pp-set-pattern 'LETREC pattern)) + + (let ((pattern '(0 . LET))) ; LET style + (%pp-set-pattern 'LET pattern) + (%pp-set-pattern 'LET* pattern) + (%pp-set-pattern 'FLUID-LET pattern)) + +;;(let ((pattern '(NEAT . (() . V-TAIL)))) ; SET! style +;; (%pp-set-pattern 'SET! pattern) +;; (%pp-set-pattern 'IF pattern) ; use default (0 . call) +;; (%pp-set-pattern 'WHEN pattern) ; for these short names +;; (%pp-set-pattern 'AND pattern) +;; (%pp-set-pattern 'OR pattern)) + + (%pp-set-pattern 'COND '(KEY . (() . COND-TAIL))) + + (%pp-set-pattern 'CASE '(KEY (() . EXP) . (2 . CASE-TAIL))) + + (%pp-set-pattern 'DO '(KEY (() . TUPLES) + (4 . COMB) + . (2 . V-TAIL))) + + (%pp-set-pattern '%PP-FUN-CALL '(0 . CALL)) ; arbitrary function calls + + (%pp-set-pattern '%PP-COMBINATION '(0 . COMB)) ; arbitrary combinations + '()) + +;;; -------------------------------------------------------------------------- + + +(define %pretty-printer + (lambda (expression margin) + (letrec + +;-------! + + ((cp margin) ; current position + + (miser-cp (max 20 (quotient margin 2))) + + (nice-fit (max 50 (quotient margin 2))) + + (call-pat (%pp-get-pattern '%PP-FUN-CALL)) + + (comb-pat (%pp-get-pattern '%PP-COMBINATION)) + + ;; + ;; PP-EXP pretty-prints expression X at the current position + ;; + + (pp-exp + (lambda (x) + (cond ((atom? x) ; X = atom ? + (pp-atom x)) + + ((atom? (cdr x)) ; X = (atom) or (atom . atom) ? + (pp-block x cp)) + + ((pair? (car x)) ; X = ((...)...) ? + (pp-by-pattern x cp comb-pat)) + + ((and (null? (cddr x)) ; X = (quote ...) + (memq (car x) '(QUOTE + QUASIQUOTE + %QQ-C %QQ-CA %QQ-CD))) + (pp-block x cp)) + + ((and (pair? (cddr x)) ; X = (... . ,value) + (null? (cdddr x)) + (eq? (cadr x) '%QQ-C)) + (pp-block x cp)) + + ((symbol? (car x)) ; X = (symbol . args) ? + (pp-by-pattern x cp + (or (%pp-get-pattern (car x)) + call-pat))) + + (else + (pp-block x cp))))) ; X = (?) + + + ;; PP-BY-PATTERN pretty-prints expression X at the current position + ;; (passed in IP) using the pattern PAT + ;; + ;; Assumptions: + ;; PAT is a valid pattern + ;; X is a pair and (cdr X) is a pair + ;; (car X) is an atom + ;; X might not be properly structured according to PAT + + (pp-by-pattern + (lambda (x ip pat) ; ip = new base for -tabs + (cond + ((number? (car pat)) ; PAT = (tab . fun) ? + (move (- ip (car pat))) + (pp-by-function x (cdr pat))) + + ((null? (car pat)) ; PAT = (() . fun) ? + (move (- cp 1)) + (pp-by-function x (cdr pat))) + + ((and (eq? (car pat) 'NEAT) + (all-fits-nicely? x)) ; X fits neatly on this line? + (pp-block x cp)) + + ;; ((and (eq? (car pat) 'ALL) + ;; (all-fits? x)) ; X fits on this line? + ;; (pp-block x cp)) + + (else ; PAT = (KEY ...) + (prin-op x) ; emit paren and keyword + (pp-by-pat-tail (cdr x) + ip ; emit the rest of X + (cdr pat))) + ))) + + (pp-by-pat-tail + (lambda (x ip pat) + (cond ((or (atom? x) ; X and PAT out of synch? + (null? pat)) + (pp-v-tail x)) ; yes, use the default method + ((eq? (car x) '%QQ-C) + (pp-block-tail x ip)) + (else + (let ((pat1 (car pat)) + (pat* (cdr pat))) + (if (atom? pat1) + (begin ; PAT matches the tail + (move (if (null? pat1) + (- cp 1) ; PAT = (() . fun) + (- ip pat1))) ; PAT = (num . fun) + (pp-by-function x pat*)) + (let ((tab1 (car pat1)) + (fun1 (cdr pat1))) + (move (if (null? tab1) + (- cp 1) ; PAT = ((() . fun) ...) + (- ip tab1))) ; PAT = ((num . fun)...) + (pp-by-function + (car x) fun1) ; pp the car + (pp-by-pat-tail ; pp the cdr + (cdr x) ip pat*)))))))) + + (pp-by-function + (lambda (x fun) + (if (null? fun) + (pp-call x) + (case fun + (exp (pp-exp x)) + (v-tail (pp-v-tail x)) + (call (pp-call x)) + (bvl (pp-block x cp)) + (tuples (pp-tuples x)) + (let (pp-let x)) + (cond-tail (pp-cond-tail x)) + (case-tail (pp-case-tail x)) + (comb (pp-comb x)) + (else (pp-call x)))))) + + (pp-let + (lambda (x) + (if (atom? x) + (pp-atom x) + (let ((p cp)) + (prin-op x) + (move (- cp 1)) + (when (and (cadr x) ; named LET ? + (atom? (cadr x))) + (set! x (cdr x)) + (pp-atom (car x)) ; name + (move (- p 5))) + (if (pair? (cdr x)) + (begin + (pp-tuples (cadr x)) ; pairs + (move (- p 2)) + (pp-v-tail (cddr x))) ; body + (pp-atomic-tail (cdr x))))))) + + (pp-call + (lambda (x) + (cond ((or (atom? x) + (null? (cdr x)) ; no arguments + (all-fits-nicely? x)) + (pp-block x cp)) + ((and (symbol? (car x)) + ( < (print-length (car x)) 5)) + (pp-hang x)) + (else + (let ((p cp)) + (prin-op x) + (move (- p 3)) + (pp-v-tail (cdr x))))))) + + (pp-comb + (lambda (x) + (cond ((or (atom? x) + (and (pair? (cdr x)) ; length = 2 ? + (null? (cddr x)) + (all-fits-nicely? x))) + (pp-block x cp)) + ((and (symbol? (car x)) + ( < (print-length (car x)) 5)) + (pp-hang x)) + (else + (pp-v x))))) + + (pp-case-tail + (lambda (x) + (if (atom? x) + (pp-atomic-tail x) + (let ((p cp) + (next (car x)) + (rest (cdr x))) + (pp-case-item next) + (if (null? rest) + (pp-atomic-tail rest) + (begin + (move p) + (pp-case-tail rest))))))) + + (pp-case-item + (lambda (x) + (cond ((atom? x) + (pp-atom x)) + ((all-fits-nicely? x) + (pp-block x cp)) + (else + (display "(") + (set! cp (- cp 1)) + (let ((p cp)) + (pp-block (car x) cp) + (move p) + (pp-v-tail (cdr x))))))) + + (pp-cond-tail + (lambda (x) + (if (atom? x) + (pp-atomic-tail x) + (let ((p cp) + (next (car x)) + (rest (cdr x))) + (pp-comb next) + (if (null? rest) + (pp-atomic-tail rest) + (begin + (move p) + (pp-cond-tail rest))))))) + + (pp-tuples + (lambda (x) + (if (and x (atom? x)) + (pp-atom x) + (begin + (display "(") + (set! cp (- cp 1)) + (pp-tuples-tail x))))) + + (pp-tuples-tail + (lambda (x) + (if (atom? x) + (pp-atomic-tail x) + (let ((p cp) + (next (car x)) + (rest (cdr x))) + (if (or (atom? next) + (all-fits-nicely? next)) + (pp-block next cp) + (pp-comb next)) + (if (null? rest) + (pp-atomic-tail rest) + (begin + (move p) + (pp-tuples-tail rest))))))) + + (pp-hang + (lambda (x) + (if (atom? x) + (pp-atom x) + (begin + (prin-op x) + (move (- cp 1)) + (pp-v-tail (cdr x)))))) + + (pp-v + (lambda (x) + (if (and x (atom? x)) + (pp-atom x) + (begin + (display "(") + (set! cp (- cp 1)) + (pp-v-tail x))))) + + (pp-v-tail + (lambda (x) + (cond ((atom? x) + (pp-atomic-tail x)) + ((eq? (car x) '%QQ-C) + (pp-block-tail x cp)) + (else + (let ((p cp) + (next (car x)) + (rest (cdr x))) + (pp-exp next) + (if (null? rest) + (pp-atomic-tail rest) + (begin + (move p) + (pp-v-tail rest)))))))) + + (pp-block + (lambda (x ip) + (if (atom? x) + (pp-atom x) + (let ((quasi (assq (car x) + '((QUOTE . "'") + (QUASIQUOTE . "`") + (%QQ-C . ",") + (%QQ-CA . ",@") + (%QQ-CD . ",."))))) + (cond ((and quasi + (pair? (cdr x)) + (null? (cddr x))) + (let* ((prefix (cdr quasi)) + (len (string-length prefix))) + (display prefix) + (set! cp (- cp len)) + (pp-block (cadr x) (- ip len)))) + (else + (display "(") + (set! cp (- cp 1)) + (pp-block-tail x (- ip 1))) ))))) + + (pp-block-tail + (lambda (x ip) + (cond ((atom? x) + (pp-atomic-tail x)) + ((and (eq? (car x) '%QQ-C) + (pair? (cdr x)) + (null? (cddr x))) + (display " . ,") + (set! cp (- cp 4)) + (pp-block (cadr x)(- ip 4)) + (display ")") + (set! cp (- cp 1))) + (else + (let* ((carx (car x)) + (fits (all-fits? carx))) + (cond ((and (not fits) + (>? ip cp)) + (move ip) + (pp-block-tail x ip)) + (else + (if fits ; print the CAR + (pp-block carx ip) + (begin + (pp-exp carx) + (move ip))) + (if (atom? (cdr x)) ; print the CDR + (pp-atomic-tail (cdr x)) + (begin + (move (- cp 1)) + (pp-block-tail (cdr x) ip)))))))))) + + (pp-atom + (lambda (x) + (write x) + (set! cp (- margin + (- (current-column) 1))))) + + (pp-atomic-tail + (lambda (x) + (cond ((null? x) + (display ")") + (set! cp (- cp 1))) + (else + (display " . ") + (set! cp (- cp 3)) + (pp-atom x) + (display ")") + (set! cp (- cp 1)))))) + + (prin-op + (lambda (x) + (let ((op (car x)) + (p cp)) + (display "(") + (set! cp (- cp 1)) + (pp-block op cp) + ;; (when ( < cp miser-cp) ;; causes a bug?? + ;; (move (- p 2))) + ))) + + (move + (lambda (p) + (when ( < cp p) + (newline) ; move left + (set! cp margin)) + (when ( > cp p) + (let ((cp4 (- cp 4))) ; move right + (if ( >= cp4 p) + (begin + (display " ") + (set! cp cp4)) + (begin + (display " ") + (set! cp (- cp 1))))) + (move p)))) + + (all-fits? + (lambda (x) + (fits-in? x cp 0))) + + (all-fits-nicely? + (lambda (x) + (fits-in? x (min cp nice-fit) 0))) + + (fits-in? ; returns length[X] if <= SIZE + (lambda (x space acc) ; returns #!FALSE otherwise + (cond ((pair? x) + (fits-in-tail? x space acc)) + ((or (symbol? x) (number? x) (string? x) + (char? x) (null? x)) + (let ((len (print-length x))) ; broken + (and ( >= space len) + (+ acc len)))) + (else #!false)))) + + (fits-in-tail? + (lambda (x space acc) + (cond ((null? acc) #!false) + (( < space 2) #!false) + ((null? x) (+ acc 1)) + ((atom? x) (fits-in? x (- space 4)(+ acc 4))) + (else + (let ((len (fits-in? (car x) space 0))) + (and len + (fits-in-tail? (cdr x) + (- (- space len) 1) + (+ (+ acc len) 1)))))))) + + (make-printable + (lambda (obj) + (cond ((closure? obj) + (apply-if (assq 'SOURCE (%reify obj 0)) + (lambda (entry) + (display obj) + (display " =") + (newline) + (cdr entry)) + obj)) + ;; other special cases ... + (else obj)))) + +;-------! + ) + (begin + (pp-exp (make-printable expression)) + *the-non-printing-object*)))) + \ No newline at end of file diff --git a/newpcs/ppeep.s b/newpcs/ppeep.s new file mode 100644 index 0000000..6385741 --- /dev/null +++ b/newpcs/ppeep.s @@ -0,0 +1,573 @@ + +; -*- Mode: Lisp -*- Filename: ppeep.s + +; Last Revision: 1-Oct-85 1630ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Post-Codegen Optimization ; +; ; +;--------------------------------------------------------------------------; +; ; +; Note: The optimization TEST+JUMP-NULL? ==> JUMP-NOT-TEST has not been ; +; implemented because peep2 can't reliably tell when TEST is dead. ; +; ; +; ; +; Revisions : ; +; 6/1/87 rb - Modified p2-substitute, so as not to monkey with %xesc ; +; 6/3/87 tc - Modified p1 register substitution to understand %xesc ; +; ; +; ; +;--------------------------------------------------------------------------; + + +(define pcs-postgen + (lambda (code) + (letrec + ( +;----! + + (peep1 + (lambda (code) + (cond (pcs-permit-peep-1 (p1 code '())) + (pcs-permit-peep-2 (reverse! code)) + (t code)))) + + (p1 + (lambda (next acc) + (if (null? next) + (begin + (p1-forget-all) + acc) + (let ((rest (cdr next)) + (instr (car next))) + (cond ((or (atom? instr) ; label + (number? (car instr))) ; label + (when (and acc + (cdr acc) + (not (atom? (car acc))) + (eq? (caar acc) 'JUMP) + (equal? (cadar acc) instr)) + (set! acc (cdr acc))) ; delete "JUMP $+1" + (p1-forget-all)) + ((memq (car instr) '(JUMP CALL LIVE)) + (p1-forget-all)) + ((eq? (car instr) 'LOAD) + (p1-propagate (cddr instr)) ; src reg + (p1-forget (cdr instr)) ; dest reg + (p1-remember (cadr instr) ; dest <== src + (caddr instr)) + ) + ((eq? (car instr) '%XESC) + ; %xesc assumes the dest reg will be equal tc - 6/3/87 + ; to the third operand (cadddr instr) + (let ((dest (cadr instr))) + (p1-propagate-all (cdr instr)) + (p1-forget (cdr instr)) ; dest reg + (p1-forget dest) ; old dest reg + (p1-remember (cadr instr) ; dest <== src + (cadddr instr)) + (p1-remember dest ; old dest <== src + (cadddr instr)) + ) + ) + ((not (atom? (cdr instr))) + (p1-propagate-all (cddr instr)) ; src regs + (p1-forget (cdr instr))) ; dest reg + (t '())) + (set-cdr! next acc) + (p1 rest next))))) + + (p1-propagate + (lambda (s*) ; (src ...) + (when (not (atom? s*)) + (let ((s (car s*))) + (when (number? s) + (let ((sub (vector-ref reg-table s))) + (when sub ; any sub + (set-car! s* sub)))))))) + + (p1-propagate-all + (lambda (s*) ; (src ...) + (when (not (atom? s*)) + (let ((s (car s*))) + (when (number? s) + (let ((sub (vector-ref reg-table s))) + (when (number? sub) ; regs only + (set-car! s* sub))))) + (p1-propagate-all (cdr s*))))) ; cdr down + + (p1-remember + (lambda (dest src) + (when (or (number? src) ; reg? + (and (not (atom? src)) ; constant + (eq? (car src) 'quote))) + (vector-set! reg-table dest src) + (set! reg-table-max + (max reg-table-max + (if (and (number? src)(> src dest)) + src + dest)))))) + + (p1-forget + (lambda (d*) ; (dest ...) + (when (not (atom? d*)) + (let ((d (car d*))) + (when (number? d) ; reg + (vector-set! reg-table d #!false) + (p1-forget-uses d)))))) + + (p1-forget-uses + (lambda (reg) + (letrec ((loop (lambda (v i reg) + (when (not (negative? i)) + (if (equal? (vector-ref v i) reg) + (vector-set! v i #!false)) + (loop v (sub1 i) reg))))) + (loop reg-table reg-table-max reg)))) + + (p1-forget-all + (lambda () + (vector-fill! reg-table #!false))) + + +;;; p2 -- peephole optimizer pass 2 + +;;; Purposes: +;;; +;;; 1. Destructively reverse the code list (previously reversed by the +;;; first pass), returning it to forward order. +;;; +;;; 2. Eliminate dead code +;;; +;;; Delete instructions whenever the destination register is dead and +;;; there are no side effects. +;;; +;;; Maintain live/dead info: destination registers are dead prior to +;;; assignment, source registers become live. LIVE directives and +;;; arguments to CALLs also control liveness. +;;; +;;; Assumption: every JUMP is immediately preceded by a LIVE. +;;; +;;; 3. Target registers +;;; +;;; Delay register moves (only), such as (LOAD A B). Mark register A +;;; as dead, register B as live. +;;; +;;; Force delayed loads whenever register A is used or a label, CALL, +;;; or JUMP occurs. +;;; +;;; Substitute register A for register B and remove the (LOAD A B) +;;; from the delayed list whenever register B is the destination of +;;; an instruction. +;;; +;;; 4. Other optimizations +;;; +;;; Eliminate no-ops: (LOAD A A) +;;; +;;; Commute operands: (+ A B A) ==> (+ A A B) +;;; +;;; +;;; Data Structures: +;;; +;;; REG-TABLE [0..63] +;;; +;;; Entry I is #!FALSE iff register I is "live" +;;; +;;; DELAY-LIST +;;; +;;; "Delayed" register moves are maintained in the form: +;;; +;;; ((LOAD Ai Bi) ...) +;;; +;;; where each Ai and Bi is a register number, no Ai=Aj, no Ai=Bj, +;;; and no Bi=Bj. The P2-DELAY routine decides whether to delay a +;;; given (LOAD A B), based on the following considerations: +;;; +;;; (= A B) : Can't happen, because P2 previously deletes these +;;; no-ops [p2-dead]. +;;; +;;; (= A Ai) : Can't happen, because Ai is "dead" and P2 would have +;;; deleted this operation [p2-dead]. +;;; +;;; (= A Bi) : Can't happen, because P2 would previously have +;;; substituted the corresponding Ai for A [p2-substitute], making +;;; this (LOAD Ai B), and no Ai=Bj. (???) +;;; +;;; (= B Ai) : Can't happen, because P2 would have forced out any +;;; delayed (LOAD Ai Bi) [p2-sources]. +;;; +;;; (= B Bi) : CAN happen. We modify the current instruction so we +;;; can continue to delay the previous (LOAD Ai Bi), as follows. +;;; +;;; Example: (load 3 5) ... (load 4 5) +;;; +;;; When we see the (LOAD 3 5), we have already delayed the +;;; (LOAD 4 5). Thus, we change (LOAD 3 5) into (LOAD 3 4), +;;; make register 4 "live", and continue to delay (LOAD 4 5). +;;; +;;; B is live : CAN happen. Don't delay the load, since the values +;;; of both A and B are needed. +;;; +;;; otherwise : delay the (LOAD A B). +;;; + + (peep2 + (lambda (code) + (cond (pcs-permit-peep-2 (p2 code '())) + (pcs-permit-peep-1 (reverse! code)) + (t code)))) + + (p2 + (lambda (next acc) + (if (null? next) + acc + (let ((rest (cdr next)) + (instr (car next))) + (begin + (set-cdr! next acc) ; assume we will keep it + ;; don't use ACC past here + (if (or (atom? instr) + (number? (car instr))) + (p2 rest (p2-force-all next)) ; label + (let ((op (car instr))) + (cond + ((eq? op 'JUMP) ; JUMP + (p2-jump instr rest next)) + + ((eq? op 'CALL) ; CALL + (p2-call instr rest next)) + + ((eq? op 'LIVE) ; LIVE + (p2-live instr rest next)) + + ((p2-dead? instr) ; result not needed + (p2 rest (cdr next))) ; delete it + + (t + (p2-substitute instr) + (if (eq? op 'LOAD) + (p2-load instr rest next) + (begin + (let ((dest (cadr instr))) + (when (number? dest) + (p2-force dest next delay-list '()) + (p2-kill dest))) + (p2-sources ; make the src regs live + (cddr instr) next) + (p2-keep rest instr next)))))))))))) + + +;;; p2-jump -- Process JUMP instructions. + + (p2-jump + (lambda (instr rest next) + (p2 rest + (p2-sources (cdddr instr) + (p2-force-all next))))) + + +;;; p2-call -- Process CALL instructions. + + (p2-call + (lambda (instr rest next) + (vector-fill! reg-table #!true) ; make all regs dead + (let ((next (p2-sources (cddr instr) + (p2-force-all next)))) ; make src regs live + (if (not (atom? (caddr instr))) + (p2-make-live 1 (car (caddr instr)))) ; number of args + (p2 rest next)))) + +;;; p2-live -- Process LIVE directives. + + (p2-live + (lambda (instr rest next) + (vector-fill! reg-table #!true) ; make all regs dead + (let ((range (cadr instr))) ; then make some live + (when (not (null? range)) + (p2-make-live (car range)(cdr range)))) + (p2 rest next))) + + (p2-make-live + (lambda (lo hi) + (when ( >= hi lo) + (vector-set! reg-table hi #!false) ; make reg live + (p2-make-live lo (sub1 hi))))) + +;;; p2-load -- Process LOAD instructions. + + (p2-load + (lambda (instr rest next) + (let ((dest (cadr instr)) + (src (caddr instr))) + (if (equal? dest src) ; no-op? + (p2 rest (cdr next)) ; delete it + (let ((live-src? (and (number? src) + (null? (vector-ref reg-table src))))) + (p2-force dest next delay-list '()) + (p2-kill dest) + (p2-sources (cddr instr) next) + (let ((acc (cdr next))) + (if (and (not live-src?) + (p2-delay next)) ; does (set-cdr! next ...) + (p2 rest acc) + (p2-keep rest instr next)))))))) + +;;; p2-substitute -- Attempt to substitute a delayed register for the +;;; destination of INSTR. If the destination of INSTR is B and a +;;; (LOAD A B) instruction has been delayed, then the destination is +;;; changed to A and the (LOAD A B) is forgotten. +;;; +;;; This substitution cannot be performed on %XESC instructions because +;;; %XESC assumes the destination is the same as the third operand + + (p2-substitute + (lambda (instr) + (letrec ((loop + (lambda (reg old new) + (if (null? old) + new + (let ((next (cdr old)) + (src (caddr (car old)))) + (if (and (= reg src) + ; don't substitute for %xesc rb - 6/1/87 + (not (eq? (car instr) '%xesc))) + (begin ; replace the dest opd + (p2-kill (cadr instr)) ; kill old dest reg + (set-car! (cdr instr) ; subst new dest reg + (cadr (car old))) + (append! next new)) ; forget it + (begin + (set-cdr! old new) + (loop reg next old)))))))) + (if delay-list + (let ((dest (cadr instr))) + (if (number? dest) + (set! delay-list + (loop dest delay-list '())))))))) + + +;;; p2-kill -- Mark the register DEST as "dead". + + (p2-kill + (lambda (dest) + (if (number? dest) + (vector-set! reg-table dest #!true)))) + + +;;; p2-sources -- Process the source registers (SS) of an instruction: +;;; 1. Mark each source register as "live". +;;; 2. For each source operand OPD which is a register for which there is +;;; a delayed assignment, force out the load, since this is the last +;;; use of a previous value. +;;; 3. Return the updated code list, NEXT. + + (p2-sources + (lambda (ss next) + (if (null? ss) + next + (let ((opd (car ss))) + (if (number? opd) ; register + (begin + (vector-set! reg-table opd #!false) ; make it live + (p2-sources (cdr ss) + (p2-force opd next delay-list '()))) + (p2-sources (cdr ss) next)))))) + + +;;; p2-force -- REG is a register which is being used as a source operand +;;; of the instruction which is at the head of CODE-LIST. Thus, we must +;;; force out any delayed load which defines or uses REG, since the source +;;; operand must refer to the old value before reassignment (defines) and +;;; we can't eliminate registers with multiple uses. Returns the updated +;;; CODE-LIST. + + (p2-force + (lambda (reg code-list old new) + (if (null? old) + (begin + (set! delay-list new) + code-list) + (let ((this (cdr old)) + (dest (cadr (car old))) + (src (caddr (car old)))) + (if (or (= reg dest) + (= reg src)) + (begin + (set-cdr! old (cdr code-list)) + (set-cdr! code-list old) + (set! delay-list (append! this new)) + code-list) + (begin + (set-cdr! old new) + (p2-force reg code-list this old))))))) + + +;;; p2-force-all -- Force all delayed register assignments out. This is +;;; necessary at all jumps, calls, labels, etc. + + (p2-force-all + (lambda (code-list) + (when delay-list + (set-cdr! code-list + (append! delay-list (cdr code-list))) + (set! delay-list '())) + code-list)) + + +;;; p2-delay -- Delay instructions of the form (LOAD reg-A reg-B) + + (p2-delay + (lambda (next) + (let ((instr (car next))) + (let ((dest (cadr instr)) + (src (caddr instr))) + (if (number? src) + (let ((delayed-load (p2-lookup src delay-list))) + (if delayed-load + (let ((delayed-dest (cadr delayed-load))) + (set-car! (cddr instr) + delayed-dest) ; fix this one + (p2-make-live delayed-dest + delayed-dest) ; keep the other delayed + '()) + (begin ; delay this one + (set-cdr! next delay-list) + (set! delay-list next) + 't))) + '()))))) ; not a reg-reg move + + (p2-lookup + (lambda (src dl) + (cond ((null? dl) '()) + ((= src (caddr (car dl))) (car dl)) + (t (p2-lookup src (cdr dl)))))) + + +;;; p2-dead? -- Determine whether instruction INSTR may be considered +;;; redundant and thus deleted. If the destination operand is "dead" and +;;; the instruction has no side effects, then the instruction is "dead". + + (p2-dead? + (lambda (instr) + (and (eq? (car instr) 'LOAD) ; no side effects + (number? (cadr instr)) ; dest reg + (or (equal? (cadr instr)(caddr instr)) + (not (null? (vector-ref reg-table (cadr instr)))))))) + + +;;; p2-keep -- Keep the current instruction, INSTR (which is also the first +;;; item in NEXT). If INSTR is a primitive that requires the first source +;;; operand to be the same as the destination register, add an appropriate +;;; LOAD in front and modify the instruction. + + (p2-keep + (lambda (rest instr next) + (let ((dest (cadr instr)) + (src (and (cddr instr)(caddr instr)))) + (cond ((or (not (number? dest)) + (not (number? src)) + (= dest src) + (memq (car instr) funny-primitives)) + (p2 rest next)) + ((member dest (cdddr instr)) + (if (and (memq (car instr) commutative-primops) + (equal? dest (cadddr instr))) + (begin ; swap source operands + (set-car! (cddr instr) dest) + (set-car! (cdddr instr) src) + (p2 rest next)) + (begin + (set-cdr! next (cons (list 'LOAD dest 63) + (cdr next))) + (set-car! (cdr instr) 63) + (set-car! (cddr instr) 63) + (p2 rest (cons (list 'LOAD 63 src) next))))) + (t + (set-car! (cddr instr) dest) + (p2 rest (cons (list 'LOAD dest src) next))))))) + + +;;; data + + (funny-primitives '(LOAD cons car cdr caar cadr cdar cddr caaar caadr + cadar caddr cdaar cdadr cddar cdddr cadddr)) + + (commutative-primops '(+ * = eq? eqv? equal? max min)) + + (delay-list '()) + (reg-table-max 0) + (reg-table (make-vector 64 #!false)) + +;----! + ) + (begin + (when pcs-verbose-flag + (writeln "Codegen results:") + (pcs-princode code) + (newline)) + (let ((code1 (peep1 code))) + (when pcs-verbose-flag + (writeln "Pass 1 optimization results:") + (set! code1 (reverse! code1)) + (pcs-princode code1) + (set! code1 (reverse! code1)) + (newline)) + (let ((code2 (peep2 code1))) + (when pcs-verbose-flag + (writeln "Pass 2 optimization results:") + (pcs-princode code2) + (newline)) + code2)))))) + + +(define pcs-princode ; PCS-PRINCODE + (lambda (code) + (letrec + ( +;----! + + (tab " ") + (tab2 " ") + (nlabels 0) + (ninstrs 0) + (nfields 0) + + (pcl + (lambda (cl) + (newline) + (when cl + (let ((x (car cl))) + (if (or (atom? x) ; label? + (number? (car x))) + (begin + (set! nlabels (add1 nlabels)) + (princ tab) + (princ x)) ; label + (begin + (set! ninstrs (add1 ninstrs)) + (princ tab2) + (pc x tab))) ; instruction + (pcl (cdr cl)))))) + + (pc + (lambda (x spacer) + (set! nfields (add1 nfields)) + (princ (car x)) + (when (cdr x) + (princ spacer) + (pc (cdr x) ", ")))) + +;----! + ) + (pcl code) + (writeln " There are " nlabels " labels, " + ninstrs " instructions, and " + nfields " fields.") + ))) + \ No newline at end of file diff --git a/newpcs/primops.s b/newpcs/primops.s new file mode 100644 index 0000000..da002c6 --- /dev/null +++ b/newpcs/primops.s @@ -0,0 +1,275 @@ + +(DEFINE < (LAMBDA (I J) (< I J))) + +(DEFINE <= (LAMBDA (I J) (<= I J))) + +(DEFINE <=? (LAMBDA (I J) (<=? I J))) + +(DEFINE <> (LAMBDA (I J) (<> I J))) + +(DEFINE <>? (LAMBDA (I J) (<>? I J))) + +(DEFINE (LAMBDA (I J) (> I J))) + +(DEFINE >= (LAMBDA (I J) (>= I J))) + +(DEFINE >=? (LAMBDA (I J) (>=? I J))) + +(DEFINE >? (LAMBDA (I J) (>? I J))) + +(DEFINE ABS (LAMBDA (J) (ABS J))) + +(DEFINE ASSOC (LAMBDA (I J) (ASSOC I J))) + +(DEFINE ASSQ (LAMBDA (I J) (ASSQ I J))) + +(DEFINE ASSV (LAMBDA (I J) (ASSV I J))) + +(DEFINE ATOM? (LAMBDA (J) (ATOM? J))) + +(DEFINE CAAAR (LAMBDA (J) (CAAAR J))) + +(DEFINE CAADR (LAMBDA (J) (CAADR J))) + +(DEFINE CAAR (LAMBDA (J) (CAAR J))) + +(DEFINE CADAR (LAMBDA (J) (CADAR J))) + +(DEFINE CADDDR (LAMBDA (J) (CADDDR J))) + +(DEFINE CADDR (LAMBDA (J) (CADDR J))) + +(DEFINE CADR (LAMBDA (J) (CADR J))) + +(DEFINE CAR (LAMBDA (J) (CAR J))) + +(DEFINE CDAAR (LAMBDA (J) (CDAAR J))) + +(DEFINE CDADR (LAMBDA (J) (CDADR J))) + +(DEFINE CDAR (LAMBDA (J) (CDAR J))) + +(DEFINE CDDAR (LAMBDA (J) (CDDAR J))) + +(DEFINE CDDDR (LAMBDA (J) (CDDDR J))) + +(DEFINE CDDR (LAMBDA (J) (CDDR J))) + +(DEFINE CDR (LAMBDA (J) (CDR J))) + +(DEFINE CEILING (LAMBDA (J) (CEILING J))) + +(DEFINE CHAR->INTEGER + (LAMBDA (J) + (CHAR->INTEGER J))) + +(DEFINE CHAR-CICHAR + (LAMBDA (J) + (INTEGER->CHAR J))) + +(DEFINE INTEGER? (LAMBDA (J) (INTEGER? J))) + +(DEFINE LAST-PAIR (LAMBDA (J) (LAST-PAIR J))) + +(DEFINE LENGTH (LAMBDA (J) (LENGTH J))) + +(DEFINE LIST-TAIL (LAMBDA (I J) (LIST-TAIL I J))) + +(DEFINE MAKE-PACKED-VECTOR + (LAMBDA (H I J) + (MAKE-PACKED-VECTOR H I J))) + +(DEFINE MEMBER (LAMBDA (I J) (MEMBER I J))) + +(DEFINE MEMQ (LAMBDA (I J) (MEMQ I J))) + +(DEFINE MEMV (LAMBDA (I J) (MEMV I J))) + +(DEFINE MINUS (LAMBDA (J) (MINUS J))) + +(DEFINE NEGATIVE? (LAMBDA (J) (NEGATIVE? J))) + +(DEFINE NOT (LAMBDA (J) (NOT J))) + +(DEFINE NUMBER? (LAMBDA (J) (NUMBER? J))) + +(DEFINE OBJECT-HASH (LAMBDA (J) (OBJECT-HASH J))) + +(DEFINE OBJECT-UNHASH + (LAMBDA (J) + (OBJECT-UNHASH J))) + +(DEFINE ODD? (LAMBDA (J) (ODD? J))) + +(DEFINE PAIR? (LAMBDA (J) (PAIR? J))) + +(DEFINE PORT? (LAMBDA (J) (PORT? J))) + +(DEFINE POSITIVE? (LAMBDA (J) (POSITIVE? J))) + +(DEFINE PRINT-LENGTH + (LAMBDA (J) + (PRINT-LENGTH J))) + +(DEFINE PROC? (LAMBDA (J) (PROC? J))) + +(DEFINE PROPLIST (LAMBDA (J) (PROPLIST J))) + +(DEFINE PUTPROP (LAMBDA (H I J) (PUTPROP H I J))) + +(DEFINE QUOTIENT (LAMBDA (I J) (QUOTIENT I J))) + +(DEFINE RATIONAL? (LAMBDA (J) (RATIONAL? J))) + +(DEFINE REAL? (LAMBDA (J) (REAL? J))) + +(DEFINE REMAINDER (LAMBDA (I J) (REMAINDER I J))) + +(DEFINE REMPROP (LAMBDA (I J) (REMPROP I J))) + +(DEFINE RESET (LAMBDA () (RESET))) + +(DEFINE REVERSE! (LAMBDA (J) (REVERSE! J))) + +(DEFINE ROUND (LAMBDA (J) (ROUND J))) + +(DEFINE SCHEME-RESET (LAMBDA () (SCHEME-RESET))) + +(DEFINE SET-CAR! (LAMBDA (I J) (SET-CAR! I J))) + +(DEFINE SET-CDR! (LAMBDA (I J) (SET-CDR! I J))) + +(DEFINE STRING->SYMBOL + (LAMBDA (J) + (STRING->SYMBOL J))) + +(DEFINE STRING->UNINTERNED-SYMBOL + (LAMBDA (J) + (STRING->UNINTERNED-SYMBOL J))) + +(DEFINE STRING-FILL! + (LAMBDA (I J) + (STRING-FILL! I J))) + +(DEFINE STRING-LENGTH + (LAMBDA (J) + (STRING-LENGTH J))) + +(DEFINE STRING-REF + (LAMBDA (I J) + (STRING-REF I J))) + +(DEFINE STRING-SET! + (LAMBDA (H I J) + (STRING-SET! H I J))) + +(DEFINE STRING? (LAMBDA (J) (STRING? J))) + +(DEFINE SUBSTRING + (LAMBDA (H I J) + (SUBSTRING H I J))) + +(DEFINE SUBSTRING-FIND-NEXT-CHAR-IN-SET + (LAMBDA (G H I J) + (SUBSTRING-FIND-NEXT-CHAR-IN-SET G H I J))) + +(DEFINE SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET + (LAMBDA (G H I J) + (SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET G H I J))) + +(DEFINE SYMBOL->STRING + (LAMBDA (J) + (SYMBOL->STRING J))) + +(DEFINE SYMBOL? (LAMBDA (J) (SYMBOL? J))) + +(DEFINE THE-ENVIRONMENT + (LAMBDA () + (THE-ENVIRONMENT))) + +(DEFINE TRUNCATE (LAMBDA (J) (TRUNCATE J))) + +(DEFINE VECTOR-FILL! + (LAMBDA (I J) + (VECTOR-FILL! I J))) + +(DEFINE VECTOR-LENGTH + (LAMBDA (J) + (VECTOR-LENGTH J))) + +(DEFINE VECTOR-REF + (LAMBDA (I J) + (VECTOR-REF I J))) + +(DEFINE VECTOR-SET! + (LAMBDA (H I J) + (VECTOR-SET! H I J))) + +(DEFINE VECTOR? (LAMBDA (J) (VECTOR? J))) + +(DEFINE WINDOW-SAVE-CONTENTS + (LAMBDA (J) + (WINDOW-SAVE-CONTENTS J))) + +(DEFINE WINDOW-RESTORE-CONTENTS + (LAMBDA (I J) + (WINDOW-RESTORE-CONTENTS I J))) + +(DEFINE ZERO? (LAMBDA (J) (ZERO? J))) + \ No newline at end of file diff --git a/newpcs/psimp.s b/newpcs/psimp.s new file mode 100644 index 0000000..8033c1e --- /dev/null +++ b/newpcs/psimp.s @@ -0,0 +1,428 @@ + +; -*- Mode: Lisp -*- Filename: psimp.s + +; Last Revision: 1-Oct-85 1630ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Program Simplification ; +; (for use only after alpha conversion) ; +; ; +;--------------------------------------------------------------------------; + + +(define pcs-simplify + (lambda (exp) + (letrec +;-------! + ((simp + (lambda (x) + (if (atom? x) + x + (case (car x) + (quote x) + (T x) ; ID record + (lambda (simp-lambda x)) + (if (simp-if (simp (if-pred x)) + (simp (if-then x)) + (simp (if-else x)))) + (set! (simp-set! (set!-id x) + (simp (set!-exp x)))) + (begin (simp-begin (simp-args (cdr x) '()))) + (letrec (simp-letrec + (simp-pairs (letrec-pairs x) '()) + (simp (letrec-body x)))) + (else (simp-application (simp-args x '()))) + )))) + + (simp-lambda + (lambda (x) ; note: preserve extra slots in the node + (begin ; This changes the apparent output of PME!! + (set-lambda-body x (simp (lambda-body x))) + x))) + + (simp-if + (lambda (p th el) + (cond ;; --- (if p (if p a b) c) ==> (if p a c) + + ((and (eq? (car th) 'if) + (dupe? p) ; no side effects + (equal? p (if-pred th))) + (simp-if p (if-then th) el)) + + ;; --- (if p a (if p b c)) ==> (if p a c) + + ((and (eq? (car el) 'if) + (dupe? p) ; no side effects + (equal? p (if-pred el))) + (simp-if p th (if-else el))) + + ;; --- (if #!false a b) ==> b + ;; --- (if '* a b) ==> a + + ((eq? (car p) 'quote) + (if (cadr p) th el)) + + ;; --- (if (not a) b c) ==> (if a c b) + + ((eq? (car p) 'not) + (simp-if (cadr p) el th)) + + ;; --- (if (begin ... p) a b) + ;; ==> (begin ... (if p a b)) + + ((eq? (car p) 'begin) + (let ((sl (reverse (cdr p)))) + (simp-begin + (reverse! (cons (simp-if (car sl) th el) + (cdr sl)))))) + + ;; --- (if (if a b c) d e) + ;; + ;; ==> (if a (if b d e) + ;; (if c d e)) + + ((eq? (car p) 'if) + (cond ((dupe? th) + (let ((a (if-pred p)) + (b (if-then p)) + (c (if-else p))) + (cond + ;; --- (if (if a 't c) d e) + ;; ==> (if a d (if c d e)) + + ((and (pair? b) + (eq? (car b) 'QUOTE) + (cadr b)) + (simp-if a th + (simp-if c th el))) + + ;; --- (if (if a b 't) d e) + ;; ==> (if a (if b d e) d) + + ((and (pair? c) + (eq? (car c) 'QUOTE) + (cadr c)) + (simp-if a (simp-if b th el) th)) + + ;; --- (if (if a a c) d e) + ;; ==> (if a d (if c d e)) + + ((and (dupe? a)(equal? a b)) + (simp-if a th (simp-if c th el))) + + (else + (list 'if p th el))))) + + ;; The following turns out to "pessimize" the code + ;; given the current code generator algorithms + + ;; ((dupe? el) + ;; (let ((a (if-pred p)) + ;; (b (if-then p)) + ;; (c (if-else p))) + ;; (cond + ;; --- (if (if a #!false c) d e) + ;; ==> (if a e (if c d e)) + + ;; ((equal? b '(quote #!false)) + ;; (simp-if a el (simp-if c th el))) + + ;; --- (if (if a b #!false) d e) + ;; ==> (if a (if b d e) e) + + ;; ((equal? c '(quote #!false)) + ;; (simp-if a (simp-if b th el) el)) + ;; (else + ;; (list 'if p th el))))) + + (else + (list 'if p th el)))) + + (else + (list 'if p th el))))) + + (dupe? + (lambda (x) + (or (atom? x) + (memq (car x) + '(T QUOTE %%get-global%% %%get-fluid%%))))) + + (simp-set! + (lambda (id exp) + (cond + ;; --- (set! a a) ==> a + + ((eq? id exp) id) + + ;; --- (set! x (if a b c)) + ;; ==> (if a (set! x b)(set! x c)) + + ((eq? (car exp) 'if) + (simp-if (if-pred exp) + (simp-set! id (if-then exp)) + (simp-set! id (if-else exp)))) + (else + (list 'set! id exp))))) + + (simp-begin + (lambda (sl) + (let ((sl (s-begin (reverse! sl) '()))) + (cond ((null? sl) '(quote ())) + ((null? (cdr sl)) (car sl)) + (else + (cons 'begin sl)))))) + + (s-begin + (lambda (old new) + (if (null? old) + new + (let ((s (car old))) + (cond ((and new ; not last exp + (memq (car s) + '(T QUOTE LAMBDA + %%get-global%% + %%get-fluid%%))) + (s-begin (cdr old) new)) ; delete s + ((or (eq? (car s) 'begin) + (and new (no-se-op (car s)))) + (s-begin (append! (reverse! (cdr s)) + (cdr old)) + new)) + (t (s-begin (cdr old) + (cons s new)))))))) + +;;; (simp-apply +;;; (lambda (fun arg) +;;; (cond +;;; ;; --- (apply (lambda (a ...) body) arg) +;;; ;; ==> (let ((L arg)) +;;; ;; (let ((a (car L))...) body)) +;;; +;;; ((and (eq? (car fun) 'lambda) +;;; (not (negative? (lambda-nargs fun)))) +;;; (simp-apply-letrec +;;; (lambda-bvl fun) (lambda-body fun) arg #!false)) +;;; +;;; (t (list '%apply fun arg))))) + +;;;(simp-apply-letrec +;;;(lambda (bvl body arg dupe?) +;;; ;; (apply (lambda () body) L) +;;; ;; ==> (begin L body) +;;; (if (null? bvl) +;;; (simp-begin (list arg body)) +;;; (let ((a (car bvl))) +;;; (cond +;;; ;; (apply (lambda (a ...) body) (cons x y)) +;;; ;; ==> (let ((a x)) +;;; ;; (apply (lambda (...) body) y)) +;;; ((eq? (car arg) 'cons) +;;; (simp-letrec +;;; `((,a ,(cadr arg))) +;;; (simp-apply-letrec +;;; (cdr bvl) body (caddr arg) #!false))) +;;; +;;; ;; (apply (lambda (a) body) L) +;;; ;; ==> (let ((a (car L))) body) +;;; ((null? (cdr bvl)) +;;; (simp-letrec +;;; `((,a (car ,arg))) +;;; body)) +;;; ;; (apply (lambda (a...) body) triv) +;;; ;; ==> (let ((a (car triv))) +;;; ;; (apply (lambda (...) body) +;;; ;; (cdr triv))) +;;; ((or dupe? +;;; (memq (car arg) '(T QUOTE))) +;;; (simp-letrec +;;; `((,a (car ,arg))) +;;; (simp-apply-letrec +;;; (cdr bvl) body `(cdr ,arg) 't))) +;;; +;;; ;; (apply (lambda (a...) body) L) +;;; ;; ==> (let ((temp L)) +;;; ;; (let ((a (car L))) +;;; ;; (apply (lambda (...) body) +;;; ;; (cdr temp)))) +;;; (t +;;; (let ((temp (pcs-make-id '()))) +;;; (simp-letrec +;;; `((,temp ,arg)) +;;; (simp-letrec +;;; `((,a (car ,temp))) +;;; (simp-apply-letrec +;;; (cdr bvl) body `(cdr ,temp) 't))))) +;;; ))))) + + (simp-letrec + (lambda (pairs body) + (cond + ;; --- (letrec () body) ==> body + + ((and (null? pairs) + (not debug-mode)) + body) + + ;; --- (letrec ((a '*)...) + ;; (begin (set! a value) ...)) + ;; --- (letrec (...(a value)) + ;; (begin ...)) + +;;; omit: works, but not worth doing +;;; ((and (eq? (car body) 'begin) +;;; (eq? (car (cadr body)) 'set!) +;;; (eq? (set!-id (cadr body)) (caar pairs)) +;;; (eq? (car (cadar pairs)) 'quote) +;;; (memq (car (set!-exp (cadr body))) +;;; '(quote lambda))) +;;; (simp-letrec +;;; (append (cdr pairs) +;;; (list +;;; (list (caar pairs) +;;; (set!-exp (cadr body))))) +;;; (simp-begin +;;; (cddr body)))) + + ;; --- (letrec ((a '*)...) + ;; (set! a value)) + ;; --- (letrec (...(a value)) + ;; a) + +;;; omit: works, but not worth doing +;;; ((and (eq? (car body) 'set!) +;;; (eq? (set!-id body) (caar pairs)) +;;; (eq? (car (cadar pairs)) 'quote) +;;; (memq (car (set!-exp body)) +;;; '(quote lambda))) +;;; (simp-letrec +;;; (append! (cdr pairs) +;;; (list +;;; (list (set!-id body) +;;; (set!-exp body)))) +;;; (set!-id body))) + + (t (list 'letrec pairs body))))) + + (simp-pairs + (lambda (old new) + (if (null? old) + (reverse! new) + (simp-pairs (cdr old) + (cons (list (caar old) + (simp (cadar old))) + new))))) + + (simp-car + (lambda (x) + (if (atom? x) + (list 'CAR x) + (let ((op (assq (car x) '((CAR . CAAR)(CADR . CAADR) + (CDR . CADR)(CDDR . CADDR) + (CDDDR . CADDDR))))) + (if op + (cons (cdr op)(cdr x)) + (list 'CAR x)))))) + + (simp-cdr + (lambda (x) + (if (atom? x) + (list 'CDR x) + (let ((op (assq (car x) '((CAR . CDAR)(CADR . CDADR) + (CDR . CDDR)(CDDR . CDDDR))))) + (if op + (cons (cdr op)(cdr x)) + (list 'CDR x)))))) + + (simp-= + (lambda (op x y) + (if (and (eq? (car y) 'QUOTE) + (number? (cadr y))) + (let ((rop (assq op '((= . =) (< . >) (> . <) + (<= . >=) (>= . <=) (<> . <>))))) + (if rop + (list (cdr rop) y x) + (list op x y))) + (list op x y)))) + + (simp-application + (lambda (comb) ; COMB is already simplified + (let ((f (car comb)) + (args (cdr comb))) + (cond ((atom? f) ; primitive + (case f +;;; ((%apply) (simp-apply (car args) (cadr args))) + ((car) (simp-car (car args))) + ((cdr) (simp-cdr (car args))) + ((= < > <= >= <>) + (simp-= f (car args) (cadr args))) + (else + comb))) + + ;; --- ((lambda () body)) ==> body + + ((and (not debug-mode) + (eq? (car f) 'lambda) + (null? args) + (null? (lambda-bvl f))) + (lambda-body f)) + + ;; --- ((lambda (a b)(foo a b)) + ;; x y) + ;; ==> (foo x y) + + ((and (not debug-mode) + (eq? (car f) 'lambda) + (let ((foo (car (lambda-body f)))) + (cond ((atom? foo) + (getprop foo 'pcs*opcode)) + ((eq? (car foo) 'T) + (not (memq foo (lambda-bvl f)))) + (else + (eq? (car foo) '%%get-global%%)))) + (equal? (cdr (lambda-body f)) ; (... a b) + (lambda-bvl f))) ; (a b) + (simp-application + (cons (car (lambda-body f)) + args))) + + ;; --- ((letrec pairs body) . args) + ;; ==> (letrec pairs (body . args)) + + ((eq? (car f) 'letrec) + (simp-letrec + (letrec-pairs f) + (simp-application + `(,(letrec-body f) . ,args)))) + + (t comb))))) + + (simp-args + (lambda (old new) + (if (null? old) + (reverse! new) + (simp-args (cdr old) + (cons (simp (car old)) + new))))) + + (no-se-op + (lambda (op) + (and (symbol? op) + (getprop op 'pcs*primop-handler) ; not a 'magic' primop + (let ((opcode (getprop op 'pcs*opcode))) + (and (integer? opcode) + (positive? opcode)))))) + +;;; data + + (debug-mode pcs-debug-mode) + +;-------! + ) + (simp exp)))) + \ No newline at end of file diff --git a/newpcs/psort.s b/newpcs/psort.s new file mode 100644 index 0000000..0afb63b --- /dev/null +++ b/newpcs/psort.s @@ -0,0 +1,135 @@ + +; -*- Mode: Scheme -*- Filename: psort.s + +; Last Revision: 15-Jan-87 0900ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Runtime ; +; (c) Copyright 1987 by Texas Instruments ; +; ; +; David Bartley ; +; ; +; Destructive SORT! routines for Vectors and Lists ; +; ; +;--------------------------------------------------------------------------; + +;; MERGE-SORT! is adapted from an algorithm contributed to TI by Dr +;; Alexander Stepanov of Polytechnic Institute of New York CS Dept, 30 +;; October 1985. Tests show it to take 60% of the time of the old PC +;; Scheme SORT! for lists. It is also faster than two different imple- +;; mentations of Quicksort, so we use it to sort both vectors and lists. + +;; (Performance figures given above are based on timings using PC Scheme +;; and should be remeasured for other implementations.) + +(define (sort! obj . rest) + (letrec + ((merge-sort! ; merge-sort! (for lists) + (lambda (L less?) + (listify! L) + (par-reduce less? L))) + + (listify! + (lambda (L) + (when (pair? L) + (set-car! L (cons (car L) '())) + (listify! (cdr L))))) + + (merge! + (lambda (less? L1 L2) + (if (less? (car L1) (car L2)) + (merge-tail less? (cdr L1) L2 L1 L1) + (merge-tail less? L1 (cdr L2) L2 L2)))) + + (merge-tail + (lambda (less? L1 L2 result last) + (cond ((null? L1) + (set-cdr! last L2) + result) + ((null? L2) + (set-cdr! last L1) + result) + ((less? (car L1) (car L2)) + (set-cdr! last L1) + (merge-tail less? (cdr L1) L2 result L1)) + (else + (set-cdr! last L2) + (merge-tail less? L1 (cdr L2) result L2))))) + + (par-reduce + (lambda (less? list) + (if (null? (cdr list)) + (car list) + (par-reduce less? (step-reduce less? list list))))) + + (step-reduce + (lambda (less? list L) + (if (null? (cdr L)) + list + (let ((next (cddr L))) + (set-car! L (merge! less? (car L)(cadr L))) + (set-cdr! L next) + (step-reduce less? list next))))) + ) + (let ((less? (or (and rest (car rest)) + %sort-less?))) + (cond ((vector? obj) (list->vector (merge-sort! (vector->list obj) less?))) + ((null? obj) obj) + ((not (pair? obj)) (%error-invalid-operand 'SORT! obj)) + ((null? (cdr obj)) obj) + (else (merge-sort! obj less?)))))) + +;; number < char < string < symbol < list < vector + +(define %sort-less? ; %SORT-LESS? + (letrec + ((type-of + (lambda (obj) + (cond ((or (null? obj) (pair? obj)) 4) + ((symbol? obj) 3) + ((vector? obj) 5) + ((string? obj) 2) + ((char? obj) 1) + ((number? obj) 0) + (else 42)))) + (symbol-less + (lambda (obj1 obj2) + (stringstring obj1)(symbol->string obj2)))) + (list-less + (lambda (obj1 obj2) + (cond ((null? obj2) #!false) + ((null? obj1) #!true) + ((less (car obj1)(car obj2)) #!true) + ((less (car obj2) (car obj1)) #!false) + (else (less (cdr obj1) (cdr obj2)))))) + (vector-less + (lambda (v1 v2) + (let ((l1 (vector-length v1)) + (l2 (vector-length v2))) + (let loop ((i1 0)(i2 0)) + (cond ((= i2 l2) #!false) + ((= i1 l1) #!true) + ((less (vector-ref v1 i1) (vector-ref v2 i2)) + #!true) + ((less (vector-ref v2 i2) (vector-ref v1 i1)) + #!false) + (else + (loop (add1 i1) (add1 i2)))))))) + (less + (lambda (obj1 obj2) + (let ((t1 (type-of obj1)) + (t2 (type-of obj2))) + (cond ((< t1 t2) #!true) + ((> t1 t2) #!false) + (else (case t1 + ((0) (< obj1 obj2)) + ((1) (charsymbol ; ASCII->SYMBOL + (lambda (n) + (string->symbol (make-string 1 (integer->char n))))) + +(define (copy x) ; COPY + (if (atom? x) + x + (cons (copy (car x)) + (copy (cdr x))))) + + +(define %delay ; %DELAY + (lambda (state) + (lambda () + (when (closure? state) ; not yet memoized? + (set! state (list (state)))) + (car state)))) + + +(define delayed-object? ; DELAYED-OBJECT? + (lambda (obj) + (and (vector? obj) + (positive? (vector-length obj)) + (eq? (vector-ref obj 0) '#!DELAYED-OBJECT)))) + + +(define (delete! obj lst) ; DELETE! + (letrec ((loop (lambda (obj a b z) + (cond ((atom? b) + z) + ((equal? obj (car b)) + (set-cdr! a (cdr b)) + (loop obj a (cdr b) z)) + (else + (loop obj b (cdr b) z)))))) + (cond ((atom? lst) + '()) + ((equal? obj (car lst)) + (delete! obj (cdr lst))) + (else + (loop obj lst (cdr lst) lst))))) + + +(define (delq! obj lst) ; DELQ! + (letrec ((loop (lambda (obj a b z) + (cond ((atom? b) + z) + ((eq? obj (car b)) + (set-cdr! a (cdr b)) + (loop obj a (cdr b) z)) + (else + (loop obj b (cdr b) z)))))) + (cond ((atom? lst) + '()) + ((eq? obj (car lst)) + (delq! obj (cdr lst))) + (else + (loop obj lst (cdr lst) lst))))) + +(define %execute ; %EXECUTE + (lambda (compiled-object) + (%%execute compiled-object))) ; dangerous primitive! + + +(define exit ; EXIT + (lambda () + (transcript-off) + (%halt) + (reset))) + +(define explode ; EXPLODE + (lambda (obj) + (let ((x (if (symbol? obj) + (symbol->string obj) + obj))) + (cond ((string? x) + (do ((x x x) + (index 0 + (add1 index)) + (end (string-length x) + end) + (result '() + (cons (string->symbol + (substring x index (+ index 1))) + result))) + ((= index end) + (reverse! result)))) + ((integer? x) + (do ((n (abs x) + (quotient n 10)) + (result '() + (cons (ascii->symbol (+ (remainder n 10) 48)) + result))) + ((< n 10) + (let ((result (cons (ascii->symbol (+ n 48)) result))) + (if (negative? x) (cons '- result) result))))) + (else x))))) + + +(define for-each ; FOR-EACH + (lambda (f l) + (do ((f f f) + (l l (cdr l))) + ((atom? l)) + (f (car l))))) + + +(define force ; FORCE + (lambda (obj) + (if (and (vector? obj) + (positive? (vector-length obj)) + (eq? (vector-ref obj 0) '#!DELAYED-OBJECT)) + ((vector-ref obj 1)) + (%error-invalid-operand 'FORCE obj)))) + + +(define gc ; GC + (lambda args + ;; do NOT define with define DEFINE-INTEGRABLE !! + ;; do NOT hoist the call to %CLEAR-REGISTERS + (cond ((or (null? args) + (null? (car args))) + (%clear-registers) ; unbind the VM registers + (%garbage-collect)) ; invoke the GC operation + (else + (%clear-registers) ; unbind the VM registers + (%compact-memory))))) ; GC and compaction both + + +(define gcd ; GCD + (lambda args + (letrec ((gcd* + (lambda (args result) + (if (null? args) + result + (gcd* (cdr args) + (gcd2 (abs (car args)) result))))) + (gcd2 + (lambda (p q) + (if (zero? q) + p + (gcd2 q (remainder p q)))))) + (gcd* args 0)))) + + +(define gensym ; GENSYM + (letrec + ((counter->string + (lambda (c n) + (cond ((positive? c) + (let ((string (counter->string (quotient c 10)(+ n 1)))) + (string-set! string + (- (string-length string) n 1) + (string-ref "0123456789" (remainder c 10))) + string)) + ((zero? n) + "0") + (else + (make-string n '())))))) + (let ((string "G") + (counter -1)) + (lambda args + (set! counter (+ counter 1)) + (when (not (null? args)) + (let ((arg (car args))) + (cond ((integer? arg) + (set! counter (abs arg))) + ((string? arg) + (set! string arg)) + ((symbol? arg) + (set! string (symbol->string arg))) + (else '())))) + (string->uninterned-symbol + (string-append string + (counter->string counter 0))))))) + + +(define head ; HEAD + (lambda (stream) + (if (and (vector? stream) + (positive? (vector-length stream)) + (eq? (vector-ref stream 0) '#!STREAM)) + (vector-ref stream 1) + (%error-invalid-operand 'HEAD stream)))) + +(define implode ; IMPLODE + (lambda (L) + (cond ((null? L) '||) + ((atom? L) + (%error-invalid-operand 'implode L)) + (else + (let ((n (length L))) + (do ((L L + (cdr L)) + (string (make-string n '()) + string) + (index 0 + (add1 index))) + ((null? L) + (string->symbol string)) + (let* ((x (car L))) + (string-set! + string + index + (cond ((symbol? x) + (string-ref (symbol->string x) 0)) + ((string? x) + (string-ref x 0)) + ((char? x) + x) + ((integer? x) + (integer->char x)) + (else + (error "Invalid list element fot IMPLODE" x)) ))))))))) + + +(define lcm ; LCM + (letrec ((lcm* + (lambda (args result) + (if (null? args) + result + (let ((a (car args))) + (if (zero? a) + 0 + (lcm* (cdr args) + (quotient (abs (* a result)) + (gcd a result))))))))) + (lambda args + (lcm* args 1)))) + + +(define (list->stream L) ; LIST->STREAM + (if (null? L) + the-empty-stream + (let ((heapL L)) ; control heap allocation of L + (cons-stream (car L) + (list->stream (cdr heapL)))))) + + +(define list->vector ; LIST->VECTOR + (lambda (L) + (let ((n (length L))) + (do ((v (make-vector n) v) + (i 0 (1+ i)) + (L L (cdr L))) + ((null? L) v) + (vector-set! v i (car L)))))) + + +(define list-ref ; LIST-REF + (lambda (x n) + (car (list-tail x n)))) + +;;; +;;; List-tail was re-defined as a primitive on 6-9-87 +;;; +;;;(define (list-tail x n) ; LIST-TAIL +;;; (if (positive? n) +;;; (list-tail (cdr x)(sub1 n)) +;;; x)) + + +(define map ; MAP + (lambda (f l) + (do ((f f f) + (l l (cdr l)) + (acc '() (cons (f (car l)) acc))) + ((atom? l) + (reverse! acc))))) + + +(define mapc ; MAPC + for-each) + + +(define mapcar ; MAPCAR + map) + + +(define random ; RANDOM + (letrec ((loop + (lambda (r m+ m) + (if (> r m+) ; enough precision? + (remainder r m) + (loop (+ (* r 8192)(%random)) m+ m))))) + (lambda (m) + (let ((r (%random))) ; 14 bits + (if (and (< m 10241) (< r (- 16383 (remainder 16383 m)))) ;10 bits scaled by 10, plus 1 + (remainder r m) + (loop r (* m 1024) m)))))) + +(define (randomize seed) ; RANDOMIZE + (let ((|2^32-1| (sub1 (* 65536 65536)))) + (if (and (<= (minus |2^32-1|) seed) + (<= seed |2^32-1|)) + (%esc2 20 seed) ;seed with the given number + (%esc2 20 0)))) ;seed derived from time of day + +(define runtime ; RUNTIME + (lambda () + (let* ((t1 (%internal-time)) + (hours (car t1)) + (minutes (cadr t1)) + (seconds (caddr t1)) + (hundreds (cadddr t1))) + (+ (* 100 (+ (* 60 (+ (* 60 hours) + minutes)) + seconds)) + hundreds)))) + + +(define stream? ; STREAM? + (lambda (obj) + (or (eq? obj the-empty-stream) + (and (vector? obj) + (positive? (vector-length obj)) + (eq? (vector-ref obj 0) '#!STREAM))))) + + +(define (stream->list stream) ; STREAM->LIST + (if (empty-stream? stream) + '() + (cons (head stream) + (stream->list (tail stream))))) + + + + +(define symbol->ascii ; SYMBOL->ASCII + (lambda (s) + (char->integer (string-ref (symbol->string s) 0)))) + + +(define tail ; TAIL + (lambda (stream) + (if (and (vector? stream) + (positive? (vector-length stream)) + (eq? (vector-ref stream 0) '#!STREAM)) + ((vector-ref stream 2)) + (%error-invalid-operand 'TAIL stream)))) + + +(define thaw ; THAW + (lambda (thunk) + (thunk))) + + +(define vector->list ; VECTOR->LIST + (lambda (v) + (do ((n (vector-length v) n) + (i 0 (1+ i)) + (L '() (cons (vector-ref v i) L))) + ((>= i n) + (reverse! L))))) + +(define boolean? ; BOOLEAN? + (lambda (obj) + (or (eq? obj #T) (null? obj) #F))) + +); end begin \ No newline at end of file diff --git a/newpcs/pstd2.s b/newpcs/pstd2.s new file mode 100644 index 0000000..c738dc7 --- /dev/null +++ b/newpcs/pstd2.s @@ -0,0 +1,194 @@ +; -*- Mode: Lisp -*- Filename: pstd2.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; Terry Caudill ; +; ; +; Scheme Standard Functions and Definitions ; +; ; +;--------------------------------------------------------------------------; + +; Revision history: +; 6/01/85 87 - Modified from former PSTL file +; +; 6/01/87 rb - added %XLI-DEBUG + +;;; Scheme 84 ENGINES + +(define pcs-null-k + (lambda (ticks eng) + (error "Null continuation invoked"))) + +(define pcs-success-k pcs-null-k) + +(define pcs-fail-k '()) + +(define pcs-engine-timeout + (lambda () + (call/cc (lambda (k) + (let ((fail pcs-fail-k)) + (set! pcs-success-k pcs-null-k) + (set! pcs-fail-k '()) ; help GC + (fail (make-engine (lambda () (k '()))))))))) + +(define pcs-kill-engine + (lambda () + (when (not (eq? pcs-success-k pcs-null-k)) + (%stop-timer) + (set! pcs-success-k pcs-null-k) + (set! pcs-fail-k '()) ; help GC + (display "[Current engine has been killed]") + (newline)))) + +;;; ``The solution to the engine tail recursion problem is to wrap the +;;; CALL/CC application in MAKE-ENGINE in an application and pass thunks to +;;; ENGINE-K. This is a very important trick to learn about CALL/CC. +;;; Serious CALL/CC hackers should study it carefully.'' +;;; +;;; -- Chris Haynes, 10/2/85 + +(define make-engine + (lambda (thunk) + (if (proc? thunk) + (lambda (ticks sk fk) + ((call/cc + (lambda (engine-k) + (when (not (eq? pcs-success-k pcs-null-k)) + (error "Engine already running")) + (when (or (not (integer? ticks)) + (not (proc? sk)) + (not (proc? fk))) + (error "Invalid argument to " ticks sk fk)) + (set! pcs-success-k + (lambda (v ticks) (engine-k (lambda () (sk v ticks))))) + (set! pcs-fail-k + (lambda (v) (engine-k (lambda () (fk v))))) + (%start-timer ticks) + (let* ((result (thunk)) + (ticks (%stop-timer))) + (%stop-timer) + (set! pcs-success-k pcs-null-k) + (set! pcs-fail-k '()) ; help gc + (error "ENGINE-RETURN not invoked")))))) + (%error-invalid-operand 'MAKE-ENGINE thunk)))) + +(define engine-return + (lambda (value) + (let* ((ticks (%stop-timer)) + (sk pcs-success-k)) + (%stop-timer) + (set! pcs-success-k pcs-null-k) + (set! pcs-fail-k '()) ; help gc + (sk value ticks)))) + +;;; +;;; Miscellaneous Functions +;;; + +(define freesp ; FREESP + (lambda () + (%esc1 3))) + +(define %hash ; %HASH + (lambda (symbol) + (%esc2 9 (symbol->string symbol)))) + +(define get-gc-compact-count ; GET-GC-COMPACT-COUNT + (lambda () + (%esc1 21))) + +(define set-gc-compact-count! ; SET-GC-COMPACT-COUNT! + (lambda (value) + (if (not (integer? value)) + (%error-invalid-operand 'set-gc-compact-count! value) + (%esc2 22 value)))) + +; 0 = off; 1 = on +(define %xli-debug ; %XLI-DEBUG + (lambda (x) + (%esc2 18 x))) + +(define %system-file-name ; %SYSTEM-FILE-NAME + (lambda (name) + (let* ((dir pcs-sysdir) + (len (string-length dir))) + (if (zero? len) + name + (string-append + (if (char=? (string-ref dir (- len 1)) #\\) + dir + (string-append dir "\\")) + name))))) + +;;; +;;; Miscellaneous Error type Functions +;;; + +(define %error-invalid-operand ; %ERROR-INVALID-OPERAND + (lambda (name opd) + (error (string-append "Invalid argument to " + (symbol->string name)) + opd))) + + +(define %error-invalid-operand-list ; %ERROR-INVALID-OPERAND-LIST + (lambda (name . opds) + (error (string-append "Invalid argument list for " + (symbol->string name)) + (cons name opds)))) + + +(define syntax-error ; SYNTAX-ERROR + (letrec ((prin (lambda (x) + (newline)(write x)))) + (lambda args + (newline) + (display "[Syntax Error] ") + (display (car args)) + (mapc prin (cdr args)) + (newline) + (display "[Returning to top level]") + (newline) + (reset)))) + + +(define pcs-clear-registers ; PCS-CLEAR-REGISTERS + (lambda () + ;; do NOT define with DEFINE-INTEGRABLE !! + (%clear-registers) ; calling this routine saves + '())) ; needed registers first + + +(define pcs-make-label ; PCS-MAKE-LABEL + (lambda (name) + (set! pcs-local-var-count (+ pcs-local-var-count 1)) + (cons pcs-local-var-count name))) + + +;;; +;;; Miscellaneous System Definitions +;;; + +(begin + (define pcs-gc-message nil) ;nil says use system defaults + (define pcs-gc-reset nil) + + (define standard-input 'CONSOLE) + (define standard-output 'CONSOLE) + (define false #!false) + (define true #!true) + (define the-empty-stream (vector 'THE-EMPTY-STREAM)) + + (define pcs-error-flag #!false) + (define pcs-binary-output #!true) + + + (define *error-code* 0) ; force these to be allocated + (define *error-message* '()) ; in USER-GLOBAL-ENVIRONMENT + (define *irritant* 0) + (define *user-error-handler* '()) +) ;begin + \ No newline at end of file diff --git a/newpcs/pstl.s b/newpcs/pstl.s new file mode 100644 index 0000000..405a954 --- /dev/null +++ b/newpcs/pstl.s @@ -0,0 +1,172 @@ +; -*- Mode: Lisp -*- Filename: pstl.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; David Bartley ; +; ; +; Standard SCHEME-Top-Level Routines ; +; ; +;--------------------------------------------------------------------------; + +; Revision history: +; 6/01/87 tc - Modified original PSTL.S so that only top level functions +; are now in this file. +; 6/01/87 rb - modified runtime-system toplevel handling so it works +; identically to the compiler version; this gets rid of +; APPLICATION-TOP-LEVEL, and PATCH.PCS and .INI handling +; will get executed in the runtime system + +;define standard toplevel loop and support functions + +(begin + (define reset-scheme-top-level ; SCHEME-TOP-LEVEL + (let ((saved-genv user-initial-environment)) + (lambda () + (letrec + ((==reset== '()) + (==scheme-reset== ; here for SCHEME-RESET + (lambda () + (%set-global-environment saved-genv) + (set! (fluid input-port) standard-input) + (set! (fluid output-port) standard-output) + (putprop '%PCS-STL-HISTORY (list '()) %pcs-stl-history) + (newline) + (display "[PCS-DEBUG-MODE is ") + (display (if pcs-debug-mode "ON]" "OFF]")) + (newline) + (call/cc (lambda (k) + (set! ==reset== (lambda ()(k '()))) + (set! (fluid scheme-top-level) + ==reset==))) + ; here for RESET (if fluid + ; SCHEME-TOP-LEVEL hasn't been redefined; + ; if it has, restart that function) + (pcs-kill-engine) + (gc) ; restore WHO line (temporary) + (more))) + (more + (lambda () + (pcs-clear-registers) + (fresh-line) + (display "[") + (display (length (getprop '%PCS-STL-HISTORY %pcs-stl-history))) + (display "] ") + (let ((problem (read))) + (flush-input) + (if (eof-object? problem) + (display "[End of file read by SCHEME-TOP-LEVEL]") + (begin + (putprop '%PCS-STL-HISTORY + (cons (list problem) + (getprop '%PCS-STL-HISTORY + %pcs-stl-history)) + %pcs-stl-history) + (let* ((answer (eval (if %pcs-stl-debug-flag + (compile (list 'BEGIN + '(%BEGIN-DEBUG) + problem)) + problem))) + (next (fluid scheme-top-level))) + (when (not (eq? answer *the-non-printing-object*)) + (write answer)) + (putprop '%PCS-STL-HISTORY + (cons (cons problem answer) + (cdr (getprop '%PCS-STL-HISTORY + %pcs-stl-history))) + %pcs-stl-history) + (if (eq? next ==reset==) + (more) + (next))))))))) + (set! (fluid scheme-top-level) ==scheme-reset==) + *the-non-printing-object*)))) + + ;;; %C accesses the nth user command + ;;; %D accesses the result of the nth user command + + (define %c ; %C + (lambda (n) + (let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history))) + (and (positive? n) + (< n (length history)) + (car (list-ref (reverse history) n)))))) + + (define %d ; %D + (lambda (n) + (let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history))) + (and (positive? n) + (< n (length history)) + (cdr (list-ref (reverse history) n)))))) +) ;begin + +(reset-scheme-top-level) + +(let ((file (%system-file-name "PATCH.PCS"))) + (when (file-exists? file) ; system patches + (load file))) + + +;; Pathnames read as text from a file will have single backslashes. +;; This doubles them so a read-from-string type operation will work on them. +;; It's used for the .INI processing following. +(define (double-slashify string) + (let loop ((m 0) + (n 0) + (new (make-string (string-length string) nil))) + (if (= m (string-length string)) + new + (begin + (string-set! new n (string-ref string m)) + (if (char=? (string-ref string m) #\\) + (let ((newer (make-string (add1 (string-length new)) nil))) + (substring-move-left! new 0 (+ n 1) newer 0) + (string-set! newer (+ n 1) #\\) + (loop (+ m 1) (+ n 2) newer)) + (loop (+ m 1) (+ n 1) new)))))) + + +(%set-global-environment user-initial-environment) + + +;; Note: You can make your own toplevel function the system's toplevel by +;; assigning it to the fluid variable SCHEME-TOP-LEVEL from the .INI file. +;; Don't invoke it yourself. After loading the .INI file, this file's +;; final SCHEME-RESET initializes the VM for toplevel recovery +;; (in case of errors) and invokes the toplevel function automatically. + + +(cond ((null? pcs-initial-arguments) ;no args at all, use scheme.ini + (when (file-exists? "scheme.ini") + (load "scheme.ini"))) + (else + (let ((pia-files + (map symbol->string + (let ((x (read (open-input-string + (double-slashify (car pcs-initial-arguments)))))) + (if (pair? x) x (list x)))))) ;handle nonlist file + (let loop ((rest pia-files) (ini-files '())) ;handle list files + (let ((f (car rest))) + (cond ((null? rest) + (when (null? ini-files) ;no ini's given, use scheme.ini + (set! ini-files '("scheme.ini"))) + (for-each ;load several ini's + (lambda (f) + (when (file-exists? f) (load f))) + ini-files)) + ((< (string-length f) 4) ;file sans extension--assumed ini + (loop (cdr rest) (cons f ini-files))) + ((substring-ci=? f (- (string-length f) 4) (string-length f) + ".app" 0 4) + (loop (cdr rest) ini-files)) ;don't reload compiler + ((substring-ci=? f (- (string-length f) 4) (string-length f) + ".xli" 0 4) + (loop (cdr rest) ini-files)) ;ignore XLI files + (else + (loop (cdr rest) (cons f ini-files))) ;assume fasl file + )))))) + + +(scheme-reset) ; must be last operation! + \ No newline at end of file diff --git a/newpcs/pwindows.s b/newpcs/pwindows.s new file mode 100644 index 0000000..720a824 --- /dev/null +++ b/newpcs/pwindows.s @@ -0,0 +1,265 @@ + +; -*- Mode: Lisp -*- Filename: pwindows.s + +; Last Revision: 10-Oct-85 1500ct + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1985 (c) Texas Instruments ; +; ; +; John Jensen ; +; ; +; Window Manipulation Routines ; +; ; +;--------------------------------------------------------------------------; + + +;;; MAKE-WINDOW returns a "default" window object with the following +;;; attributes: +;;; +;;; Upper Left Hand Corner = 0,0 +;;; Size (Lines, Columns) = 25,80 or 30,80 (the entire screen) +;;; Cursor Position = 0,0 +;;; Text Color = White (on IBM, high intensity white) +;;; Border Color (if bordered) = Green (on IBM, low intensity green) +;;; Transcript Recording = Enabled + +(define make-window ; MAKE-WINDOW + (lambda args + (let ((label (car args)) + (bordered? (cadr args))) + (if (or (null? label) (string? label)) + (let ((window (%make-window label))) + (when bordered? + (%reify-port! window 6 (if (eqv? pcs-machine-type 1) + #b00001100 ; TIPC green + #b00001010))) ; IBM green + window) + (begin + (%error-invalid-operand 'MAKE-WINDOW label) + '()))))) + + +;;; WINDOW-CLEAR erases the data portion of a window (writes blanks using +;;; the current text attributes) and positions the cursor in position +;;; 0,0 (the upper left hand corner of the window). If the window is +;;; bordered, the border is re-drawn by this operation. This operation +;;; more properly may be considered a "window-initialize" operation. + +(define WINDOW-CLEAR ; WINDOW-CLEAR + (lambda (window) + (if (or (window? window) (null? window)) + (%clear-window window) + (begin + (%error-invalid-operand 'WINDOW-CLEAR window) + '())))) + + +;;; The "delete-window" function completely erases the area of the CRT which +;;; is covered by a given window, including the borders. This function +;;; accomplishes the erasing of the borders by expanding the dimensions +;;; of the window (temporarily) so that the borders are included in the +;;; data portion of the window; setting the border attribute to "no +;;; border"; and issuing a "%clear-window" operation to clear the text +;;; portion of the (temporarily) expanded window. After clearing the +;;; window and border, the original attributes of the window are +;;; restored. +;;; +;;; Note: when expanding the size of the window to account for the +;;; right and bottom borders, this routine takes advantage of the fact +;;; that %reify-port will not allow a window's boundaries to be set +;;; to be larger than the physical device size. Therefore, no check +;;; is performed to see if the right and bottom borders are off the +;;; screen. + +(define WINDOW-DELETE ; DELETE-WINDOW + (lambda (window) + (if (or (window? window) (null? window)) + (if (eqv? (%reify-port window 6) -1) + (%clear-window window) ; if not bordered, just do a %clear-window + (let ((ul-line (%reify-port window 2)) ; save current attributes + (ul-col (%reify-port window 3)) ; for later restoration + (n-lines (%reify-port window 4)) + (n-cols (%reify-port window 5)) + (b-attrib (%reify-port window 6)) + (t-lines '()) + (t-cols '())) + (begin + (when (> ul-line 0) + (begin ; increase window size to include top border + (%reify-port! window 2 (-1+ ul-line)) + (%reify-port! window 4 (1+ n-lines)))) + (when (> ul-col 0) + (begin ; increase window size to include left border + (%reify-port! window 3 (-1+ ul-col)) + (%reify-port! window 5 (1+ n-cols)))) + (set! t-lines (%reify-port window 4)) ; get new window size + (set! t-cols (%reify-port window 5)) + (%reify-port! window 4 (1+ t-lines)) ; include bottom border + (%reify-port! window 5 (1+ t-cols)) ; include right border + (%reify-port! window 6 -1) ; indicate no border + (%clear-window window) + (%reify-port! window 2 ul-line) ; restore the original + (%reify-port! window 3 ul-col) ; attributes to the user's + (%reify-port! window 4 n-lines) ; window + (%reify-port! window 5 n-cols) + (%reify-port! window 6 b-attrib)))) + (begin + (%error-invalid-operand 'WINDOW-DELETE window) + '())))) + + +;;; WINDOW-GET-POSITION conses the coordinates of the upper left hand +;;; position of a window into a pair as: (line . column) + +(define WINDOW-GET-POSITION ; WINDOW-GET-POSITION + (lambda (window) + (if (or (window? window) (null? window)) + (cons (%reify-port window 2) (%reify-port window 3)) + (begin + (%error-invalid-operand 'WINDOW-GET-POSITION window) + '())))) + + +;;; WINDOW-GET-SIZE conses the number of lines and columns in a window +;;; (excluding the border columns, if any) into a pair as: +;;; (lines . columns) + +(define WINDOW-GET-SIZE ; WINDOW-GET-SIZE + (lambda (window) + (if (or (window? window) (null? window)) + (cons (%reify-port window 4) (%reify-port window 5)) + (begin + (%error-invalid-operand 'WINDOW-GET-SIZE window) + '())))) + + +;;; WINDOW-GET-CURSOR conses the line and column number of the current +;;; cursor position into a pair as: (line . column) + +(define WINDOW-GET-CURSOR ; WINDOW-GET-CURSOR + (lambda (window) + (if (or (window? window) (null? window)) + (cons (%reify-port window 0) (%reify-port window 1)) + (begin + (%error-invalid-operand 'WINDOW-GET-CURSOR window) + '())))) + + +;;; The following routines modify the position, size, and cursor position +;;; of a window by side effecting the appropriate fields in a window +;;; object. An argument value of '() indicates that a particular +;;; field's value is to remain unchanged. + +(define WINDOW-SET-POSITION!) +(define WINDOW-SET-SIZE!) +(define WINDOW-SET-CURSOR!) +(letrec ((chk-and-set + (lambda (window line column instruction-name L C) + (cond + ((not (or (window? window) (null? window))) + (error (string-append "Invalid Window Argument to " + (symbol->string instruction-name)) + window)) + ((and line + (or (not (integer? line)) + (negative? line))) + (error (string-append "Invalid Line Number to " + (symbol->string instruction-name)) + line)) + ((and column + (or (not (integer? column)) + (negative? column))) + (error (string-append "Invalid Column Number to " + (symbol->string instruction-name)) + column)) + (else + (when line (%reify-port! window L line)) + (when column (%reify-port! window C column)) + window))))) + (set! WINDOW-SET-POSITION! ; WINDOW-SET-POSITION! + (lambda (window ul-line ul-col) + (chk-and-set window ul-line ul-col + 'WINDOW-SET-POSITION! 2 3))) + (set! WINDOW-SET-SIZE! ; WINDOW-SET-SIZE! + (lambda (window n-lines n-cols) + (chk-and-set window n-lines n-cols + 'WINDOW-SET-SIZE! 4 5))) + (set! WINDOW-SET-CURSOR! ; WINDOW-SET-CURSOR! + (lambda (window cur-line cur-col) + (chk-and-set window cur-line cur-col + 'WINDOW-SET-CURSOR! 0 1)))) + + +;;; Pop-Up window manipulation. +;;; +;;; "WINDOW-POPUP" preserves the data on the screen which will be +;;; covered by the pop-up window, initializes the window, and +;;; returns the pop-up window object to the caller. +;;; +;;; "WINDOW-POPUP-DELETE" restores the region of the CRT covered by a +;;; window created "WINDOW-POPUP" to its state prior to the +;;; pop-up window's appearance. + +(define WINDOW-POPUP) +(define WINDOW-POPUP-DELETE) +(let ((pop-up-list '())) + (begin + (set! WINDOW-POPUP ; WINDOW-POPUP + (lambda (window) + (if (or (window? window) (null? window)) + (begin + (set! pop-up-list + (cons (cons window (window-save-contents window)) pop-up-list)) + (window-delete window) + (%clear-window window) + window) + (begin + (%error-invalid-operand 'WINDOW-POPUP window) + '())))) + (set! WINDOW-POPUP-DELETE ; WINDOW-POPUP-DELETE + (lambda (window) + (let ((saved-data (assq window pop-up-list))) + (when (not (null? saved-data)) + (window-restore-contents window (cdr saved-data)) + (set! pop-up-list (delq! saved-data pop-up-list)) + window)))) )) + + +;;; The following routines get and set window attributes which are not +;;; modifiable by any of the above routines. It is necessary to explicitly +;;; name the attribute you wish to examine/modify. + +(define WINDOW-GET-ATTRIBUTE) +(define WINDOW-SET-ATTRIBUTE!) +(letrec ((attr-list '((border-attributes . 6) + (text-attributes . 7) + (window-flags . 8))) + (check-and-map-args + (lambda (window attribute) + (if (or (window? window) (null? window)) + (cdr (assq attribute attr-list)) + #!FALSE)))) + (set! WINDOW-GET-ATTRIBUTE + (lambda (window attribute) + (let ((mapped-attribute (check-and-map-args window attribute))) + (if mapped-attribute + (%reify-port window mapped-attribute) + (begin + (%error-invalid-operand-list 'WINDOW-GET-ATTRIBUTE + window attribute) + '()))))) + (set! WINDOW-SET-ATTRIBUTE! + (lambda (window attribute value) + (let ((mapped-attribute (check-and-map-args window attribute))) + (if (and mapped-attribute + (integer? value) + (< value #x3fff) + (> value #x-3fff)) + (%reify-port! window mapped-attribute value) + (begin + (%error-invalid-operand-list 'WINDOW-SET-ATTRIBUTE! + window attribute value) + '())))))) + \ No newline at end of file diff --git a/newpcs/scpsdemo.s b/newpcs/scpsdemo.s new file mode 100644 index 0000000..d483ac8 --- /dev/null +++ b/newpcs/scpsdemo.s @@ -0,0 +1,135 @@ +; +; This is an example of using SCOOPS. Please refer to chapter 5 in the +; Language Reference Manual for TI Scheme. +; +; The first thing that needs to be done is to define classes for different +; types. We will define three types, points, lines and rectangles. + +(load "scoops.fsl") + +;;; +;;; Point, Line and Rectangle +;;; + +;;; +;;; Class POINT +;;; + +(define-class point + (instvars (x (active 0 () move-x)) + (y (active 0 () move-y)) + (color (active 'yellow () change-color))) + (options settable-variables + inittable-variables)) + +(compile-class point) ; see page 45 in the language reference manual + +;;; +;;; Class LINE +;;; + +(define-class line + (instvars (len (active 50 () change-length)) + (dir (active 0 () change-direction))) + (mixins point) ; inherit x, y, and color from point class. + (options settable-variables)) + +(compile-class line) + +;;; +;;; Class RECTANGLE +;;; + +(define-class rectangle + (instvars (height (active 60 () change-height))) + (mixins line) ; inherit color and width (len) from line + (options settable-variables)) + +(compile-class rectangle) + +; In order to have an occurance of a class you will need to use the +; MAKE-INSTANCE procedure. For example: +; (define p1 (make-instance point)) +; Then to change parts of the class use the send function. For example +; to change the color of the point previously defined: +; (send p1 change "color" 'cyan) +; + +;;; +;;; Methods for POINT +;;; + +(define-method (point erase) () + (set-pen-color! 'black) + (draw)) + +(define-method (point draw) () + (draw-point x y)) + +; having both a draw and redraw function here may seem to be unnecessary. +; you will see why both are needed as we continue + +(define-method (point redraw) () + (set-pen-color! color) + (draw)) + +(define-method (point move-x) (new-x) + (erase) + (set! x new-x) + (redraw) + new-x) + +(define-method (point move-y) (new-y) + (erase) + (set! y new-y) + (redraw) + new-y) + +(define-method (point change-color) (new-color) + (erase) + (set! color new-color) + (redraw) + new-color) +;;; +;;; Methods for LINE +;;; + +; inherit erase, redraw, move-x, move-y and change-color from point. + +(define-method (line draw) () + (position-pen x y) + (draw-line-to (truncate (+ x (* len (cos dir)))) + (truncate (+ y (* len (sin dir)))))) + +(define-method (line change-length) (new-length) + (erase) + (set! len new-length) + (redraw) + new-length) + +(define-method (line change-direction) (new-dir) + (erase) + (set! dir new-dir) + (redraw) + new-dir) + +;;; +;;; Methods for RECTANGLE +;;; + +; inherit erase, redraw, move-x, move-y and change-color from point. + +(define-method (rectangle draw) () + (position-pen x y) + (draw-line-to (+ x len) y) + (draw-line-to (+ x len) (+ y height)) + (draw-line-to x (+ y height)) + (draw-line-to x y)) + +(define-method (rectangle change-height) (new-height) + (erase) + (set! height new-height) + (redraw) + new-height) + + \ No newline at end of file diff --git a/pro2real.asm b/pro2real.asm new file mode 100644 index 0000000..19c2295 --- /dev/null +++ b/pro2real.asm @@ -0,0 +1,1707 @@ +; =====> PRO2REAL.ASM +; PC Scheme Protected Mode -> Real Mode Interface +; (c) 1987 by Texas Instruments Incorporated -- all rights reserved +; +; This Module contains code which interfaces to external programs via +; either the External Language Interface (XLI), Software Interrupt, +; or the Real Procedure Call (RPC). The RPC is specific to protected +; mode scheme only, and is used to implement XLI. + +; Author: Terry Caudill (from Bob Beal's original source) +; History: +; rb 3/20/87 - original +; tc 8/7/87 - to work in protected mode scheme +; tc 10/13/87 - cleanup + + + page 84,120 + name EXTPROG + title PC Scheme External Program Interface + .286c + + + subttl Includes and Local Equates + page + + include scheme.equ + include sinterp.arg + include xli.equ + include xli_pro.mac + include rpc.equ + +; +; Dos function requests +; +DOS equ 021h ; Dos Function Request +DELETE_SEG equ 04900h ; Delete Segment +REAL_INTRP equ 0E3h ; Issue Real Interrupt - from AIA +BLOCK_XFER equ 0EC00h ; Block Transfer - from AIA +ALLOC_REAL equ 0E802h ; Create Real Data Seg - from AIA +CREATE_WIN equ 0E803h ; Create Real Window - from AIA + + + subttl Group and Constant definitions + page +pgroup group prog +xgroup group progx +dgroup group data + + + subttl Data segment definitions + page + +data segment para public 'DATA' + assume ds:dgroup + public rpc_handle + public REAL_MODE_BUFFER,REAL_BUF_OFFSET,REAL_BUF_SELECTOR + public REAL_BUF_PARA,REAL_BUF_TOP + public C_fn + public mem_entry,mem_table +; external variables + extrn ctl_file:word,pcs_sysd:word + extrn regs:word + extrn vid_mode:word,char_hgt:word + +; +; The following data definitions are used in communication with real +; mode procedures and the real procedure call (RPC) mechanism provided +; in OS/286 by AI Architects. +; + +rpc_real db "realschm.exe",0 ; Name of RPC file to load +rpc_real_len equ $-rpc_real + +rpc_handle db 0 ; Handle to real mode scheme routines +rpc_loaded db 0 ; Flag to note if rpc load was successful +rpc_saved_sp dw ? ; Saved stack pointer + +REAL_MODE_BUFFER equ $ ; selector and offset of real mode +REAL_BUF_OFFSET dw 0 ; offset of real mode buffer +REAL_BUF_SELECTOR dw 0 ; segment selector of real mode buffer +REAL_BUF_PARA dw 0 ; segment address of real mode buffer +REAL_BUF_TOP dw 0 ; note buffer top + +; +; The following are xli filenames which must be loaded and used by pcs +; +io_exe db "realio.exe" ,0 ;EXE file providing I/O support +io_exe_len equ $-io_exe + +graph_exe db "graphics.exe" ,0 ;EXE file providing graphics support +graph_exe_len equ $-graph_exe + +trig_exe db "newtrig.exe" ,0 ;EXE file providing trig support +trig_exe_len equ $-trig_exe + +; +; The following table is used to load the system files required by pcs. The +; xli system files are order dependent. +sys_files equ $ +;system xli files, order is dependent (see rpc.equ and realschm.asm) + dw io_exe,io_exe_len ;io support - xli system file + dw graph_exe,graph_exe_len ;graphics support - xli system file +;normal xli files +normal_files equ $ + dw trig_exe,trig_exe_len ;trig file - normal xli file + dw 0 +; +; If the above files cannot be found, issue this message and abort scheme +; +FILERR db 0Dh,0Ah,"Fatal Error - unable to load file " +FILNAM db 20 dup (0) + +; +; The following table contains gateways from the prog segment to the +; progx segment. The order is dependent on +; Table of RPC functions currently defined. Calling any of these functions +; requires synchronization with the real mode routine. +; +FAR_RPC equ $ +frpc_bid equ $-FAR_RPC + dw init_rpc,progx ; bid real procedure +frpc_init equ $-FAR_RPC + dw xpcinit,progx ; get machine type +frpc_setcrt equ $-FAR_RPC + dw xsetcrt,progx ; set crt interrupt +frpc_resetcrt equ $-FAR_RPC + dw xresetcrt,progx ; reset crt interrupt +frpc_ldall equ $-FAR_RPC + dw load_all,progx ; load xli files +frpc_unld equ $-FAR_RPC + dw unload_all,progx ; unload xli files +frpc_xesc equ $-FAR_RPC + dw xesc,progx ; perform xesc call + +; +; The following hooks are used to call routines in the PROG segment +; from the PROGX segment. See the far_C routine in this module. +; +C_fn dw ? +C_retadr dw ? ; Used to call C routines from PROGX + dw ? + +; +; Mem_table is used to hold selectors to real memory which must be allocated +; over the life of an xli call. At present, the memory is allocated so that +; xli routines may access far strings. See SSR within. +; +mem_entry dw 0 ;entry into memory table +mem_table dw N_ARGS dup (0) ;record memory allocated during xli call + +; +; The following structures allow xesc and sw-int to share code +; +xesc_func db ? ;0 = sw-int, 1 = xesc +error_return dw ? ;address of error handler + +which_func dw swi_txt,xli_txt ;will be indexed by xesc_func above +swi_txt db 'SW-INT',0 +xli_txt db 'XCALL',0 + +; +; Error return values for software interrupt +; +SWI_ERR_ARGN_BAD_TYPE equ 1 ; Bad argument passed to sw-int +SWI_ERR_VALUE_BAD_TYPE equ 2 ; Bad type passed to sw-int +SWI_ERR_BIG_TO_32_BITS equ 3 ; Number to large for sw-int + +swi_errs dw swi_arg0,swi_arg1,swi_arg2 + +; +; Software Interrupt error messages +; +swi_arg0 db 'Invalid argument to SW-INT',0 +swi_arg1 db 'Invalid return value for SW-INT',0 +swi_arg2 db 'Argument to SW-INT too large to fit in 32 bits',0 + +; +; Protected Mode Fatal type errors +; +cr_win db 'CREATE WINDOW',0 +al_seg db 'ALLOCATE SEGMENT',0 +dl_seg db 'DELETE SEGMENT',0 +rl_int db 'ISSUE REAL INTERRUPT',0 + +; +; Gate to abort code in sc.asm +; + + +data ends + + + subttl Progx code segment definitions + page + +; external routines + extrn alloc_fl:near,int2long:near,long2int:near,alloc_bl:near + extrn getbase:near + extrn chg_vmode:near + extrn pro_erro:near + +progx segment para public 'PROGX' + assume cs:xgroup,ds:dgroup,es:dgroup,ss:dgroup + + extrn xcabt:far + + public init_rpc,xpcinit,xsetcrt,xresetcrt,xesc,load_all,unload_all + public ssr + public do_floarg,do_fixarg,do_bigarg,do_strarg + public do_floval,do_intval,do_TFval,do_strval + public softint,swi_strarg,swi_strval + + + + subttl RPC interface routines + page + +; INIT_RPC +; Load the real mode portion of scheme and save the handle in rpc_handle. +; Then call the rpc routine to return the real address of a buffer which +; will be used on subsequent rpc requests. This buffer is mapped to a +; protected mode selector and stored in REAL_BUF_SELECTOR. +; +; The transaction buffer for an rpc must be pointed to by DS:DX. Note that +; we build this buffer up on the local stack. +; +init_rpc proc far + push bp + sub sp,80 ;allocate transaction buffer + mov bp,sp ;should be large enough for filename + cld + mov di,pcs_sysd ;di => system directory pathname + mov cx,64 ;cx = max length + mov al,0 + repne scasb ;scan pathname for eos character (=0) + jcxz ini_10 ;jump if none + dec di ;di => end of pathname +ini_10: + mov cx,di + sub cx,pcs_sysd ;cx = length of system directory + mov di,sp ;di => stack (transaction buffer) + mov si,pcs_sysd ;si => pcs-sysdir + rep movsb ;copy system directory into buffer + mov al,'\' ;follow directory name with \ + stosb + mov si,offset rpc_real + mov cx,rpc_real_len + rep movsb ;follow directory w/real proc filename + +;Initialize real procedure call + mov dx,sp ;ds:dx => real procedure filename + mov ah,RPC_INIT ;load and init real procedure + int DOS ;extended Dos call for Protected mode + jnc ini_20 ;continue if no error encountered + + mov ax, offset rpc_real ;ax => file that couldn't load + mov cx,rpc_real_len ;cx => length of filename + jmp fatal_file_err ;jump to fatal error handler + +ini_20: + mov rpc_handle,al ;save handle to real procedure + inc rpc_loaded ;note real procedure loaded + +; Obtain communication buffer for subsequent RPC calls + mov dx,bp ;ds:dx => transaction buffer + mov word ptr [bp],RPCRETBUF ;return real buffer opcode + mov cx,8 ;pass 8 bytes + mov bx,cx ;expect 8 bytes returned + mov ah,RPC ;issue Real Procedure Call + int DOS ;extended Dos call for Protected mode + ;ignore return status + + mov dx,[bp]+2 ;get length of buffer + sub dx,2 ;calc top of stack + mov REAL_BUF_TOP,dx ; and save + mov si,sp + add si,4 ;ds:si => real address of buffer + mov ax,[si]+2 ;get paragraph address + mov REAL_BUF_PARA,ax ; and save +;ds:si=> offset,seg of real buffer, dx=length + call map_real_mem ;map real address to protected selector + mov REAL_BUF_SELECTOR,ax ; and save + + add sp,80 ;now clean up the stack + pop bp + ret ;and return +init_rpc endp + +; XPCINIT +; Determine the machine type and perform machine specific initialization. +; Call the real mode routine to perform initialization functions via the +; RPC mechanism. +; +; Input: none +; Output: return status, pc machine type, and video mode are returned +; in the communications buffer accessed by REAL_MODE_SELECTOR. +; +xpcinit proc far + push RPCTYPE ; Type code + mov dx,sp ; ds:dx => arg buffer + mov cx,2 ; cx = # arg bytes passed + mov bx,cx ; bx = # result bytes expected + mov al,rpc_handle ; Handle to real mode part + mov ah,RPC ; Real Procedure Call + int DOS ; Extended Dos call for Protected mode +; Check for errors here + pop ax ; ignore return status +; Get the return values from the real mode buffer + MOVE_ARGS_FROM_BUF ,REAL_MODE_BUFFER + + mov ax,ds + mov es,ax ; restore extra seg reg + ret ; and return +xpcinit endp + + +; XSETCRT +; Take over the real mode crt interrupt handler during a dos-call so that +; display will not be written to. +; +; Input: none +; Output: screen output will be inhibited +; +xsetcrt proc far + push RPCTAKCRT ; Take over crt interrupt handler + mov dx,sp ; ds:dx => arg buffer + mov cx,2 ; cx = # arg bytes passed + mov bx,cx ; bx = # result bytes expected + mov al,rpc_handle ; Handle to real mode part + mov ah,RPC ; Real Procedure Call + int DOS ; Extended Dos call for Protected mode + pop ax ; ignore return status + ret ; and return +xsetcrt endp + + +; XRESETCRT +; Restore the original crt interrupt handler after a dos call so that the +; display can once again be written to. +; +; Input: none +; Output: screen output will be restored +; +xresetcrt proc far + push RPCRSTCRT ; Restore crt interrupt handler + mov dx,sp ; ds:dx => arg buffer + mov cx,2 ; cx = # arg bytes passed + mov bx,cx ; bx = # result bytes expected + mov al,rpc_handle ; Handle to real mode part + mov ah,RPC ; Real Procedure Call + int DOS ; Extended Dos call for Protected mode +; Check for errors here + pop ax ; ignore return status + ret ; and return +xresetcrt endp + + + + subttl RPC interface routines to XLI + page + +; LOAD_ALL +; A portion of the XLI routines is in real mode and is communicated with +; via the Real Procedure Call (RPC). Data must be passed to the real mode +; routine via the real buffer REAL_MODE_BUFFER +; +; Any errors encountered are currently ignored. + +l_save struc +exe_name dw ? ;index to start of exe name +handle dw ? ;file handle +l_len db ? ;marker for size of local area +l_save ends + +load_all proc far + push bp + sub sp,l_len ;allocate local storage + mov bp,sp + +; calc length of pathname + cld + mov di,pcs_sysd + mov cx,64 ;max length of pathname + mov al,0 + repne scasb ;look for eos character (=0) + jcxz la_10 ;jump if none + dec di +la_10: + mov cx,di + sub cx,pcs_sysd ;cx = length of pcs-sysdir +; copy pcs-sysdir into transaction buffer + push cx ;tempsave length + RESET_REAL_BUFFER_OFFSET ;ensure start at buffer start + MOVE_ARGS_TO_BUF <1>,REAL_MODE_BUFFER,autoincr ;system file first + add di,2 ;save space for exe index + pop cx ;restore length + mov si,pcs_sysd ;ds:si addresses pcs-sysdir + MOVE_TO_REAL_BUF autoincr ;move to real memory buffer + + mov al,'\' ;append \ onto pcs-sysdir name + MOVE_BYTE_TO_BUF al,,autoincr +;save index to exe filename + mov [bp].exe_name,di ;save offset after pcs-sysdir + mov bx,di ;save offset after pcs-sysdir + mov di,2 + MOVE_ARGS_TO_BUF ;save index to exe file + + mov di,bx ;position offset for .EXE name +;save control filename to transaction buffer + mov bx,ctl_file ;get address of ctl file + cmp byte ptr [bx],'-' ;user override normal xli files? + jne sysload ; no, jump + mov word ptr normal_files,0 ; Yes, don't load normal xli files + inc ctl_file ; bump ptr to name +sysload: +; load all system files - di should not be modified in following loop + mov si,offset sys_files +loadfile: + push si ;save offset into file table + mov cx,ds:[si+2] ;cx = length + mov si,ds:[si] ;si => filename + MOVE_TO_REAL_BUF ;copy filename to buffer + push RPCLDEXE ;RPC request code to load EXE + mov dx,sp ;ds:dx => rpc request code + mov cx,2 ;cx = # arg bytes passed + mov bx,cx ;bx = # arg bytes returned + mov al,rpc_handle ;al = handle + mov ah,RPC ;Issue Real Procedure Call + int DOS ;Issue extended dos funcall + pop ax ;ah = flags, al= return status + pop si ;restore index into file table + sahf ;load flags + jnc load_10 ;no carry, proceed + mov cx,ds:[si+2] ;cx = length + mov ax,ds:[si] ;si => filename + jmp fatal_file_err ;go report error +load_10: + add si,4 ;address next entry + cmp word ptr ds:[si],0 ;any more entrys? + jne loadfile ; yes, loop +userload: + xor di,di ;address system flag + MOVE_ARGS_TO_BUF <0> ;indicate user defined xli + mov di,[bp].exe_name ;di = index to exe name +; open XLI control file + mov dx,ctl_file ;dx = address of filename + mov ax,FR_OPEN ;dos function - open file + int DOS + mov [bp].handle,ax ;save handle + jnc next_file ;jump if no open errors + jmp close1 ;can't open file, exit +; read in next filename off the control file and append it to +; the pcs-sysdir name. +next_file: + mov di,[bp].exe_name ;es:di => buffer after pathname + mov bx,[bp].handle ;bx = file handle +next_char: + push 0 ;allocate place on stack + mov dx,sp ;dx = address of buffer + mov cx,1 ;read one character + mov ax,FR_READ ;dos function - read file + int DOS ;ignore errors + pop dx ;retrieve character + jnc la_20 ;jump if no error, else + ;suddenly can't read control + ;file, close it and exit +close: + mov bx,[bp].handle ;bx = file handle + mov ax,FR_CLOSE ;dos functions - close file + int DOS ;ignore errors +close1: + add sp,l_len ;adjust stack + pop bp + ret ;return + +la_20: cmp ax,0 ;at eof? + jz close ;yes, jump +; we've read a character + cmp dl,0Dh ;carriage return? + je got_file ;yes, jump + cmp dl,' ' ;blank or control char? + jle next_char ;yes, skip it + MOVE_BYTE_TO_BUF dl,,autoincr ;move character to buffer + jmp next_char +; we've read a complete filename, go load it +got_file: + MOVE_BYTE_TO_BUF 0 ;form ASCZII string + + push RPCLDEXE ;RPC request code to load EXE + mov dx,sp ;ds:dx => rpc buffer + mov cx,2 ;cx = # arg bytes passed + mov bx,cx ;bx = # arg bytes returned + mov al,rpc_handle ;al = handle + mov ah,RPC ;Issue Real Procedure Call + int DOS ;Issue extended dos funcall + pop ax ;bump result arg from stack + sahf ;ah = flags + jnc next_file ;jump if no errors + xor ah,ah ;clear flags from result + cmp ax,0 ;any open slots? + je close ;no, jump + cmp ax,2 ;file found? + je next_file ;no, jump + cmp ax,8 ;ran out of memory? + jne next_file ;no, jump; ignorable error + jmp close ;yes +load_all endp + + +; UNLOAD_ALL +; Call the real mode routine to unload all exe files. +; +; Upon exit: +; All previously bid xli programs will be released from real memory. +; +unload_all proc far + push RPCUNLDALL ; RPC request code to unload all exe's + mov dx,sp ; ds:dx => arg buffer + mov cx,2 ; cx = # arg bytes passed + mov bx,2 ; bx = # result bytes expected + mov al,rpc_handle ; Handle to real mode part + mov ah,RPC ; Real Procedure Call + int DOS ; Extended Dos call for Protected mode + pop ax ; ignore errors + ret +unload_all endp + +; FATAL_FILE_ERR +; We are unable to load a system file in real mode, and cannot +; continue with scheme. The routine XCABT (in sc.asm) will output +; a message (via DOS function 9) to the console and abort. Our +; io may not be available at the time of this error. +; +; On entry: +; ax => filename we are trying to load +; cx = length of filename +; + public fatal_file_err +fat_err proc near +fatal_file_err label near + mov bx,ss + mov ds,bx + mov es,bx ;ds,es,ss = data segment + mov si,ax ;ds:si addresses filename + mov di,offset FILNAM ;es:di addresses message + rep movsb ;move filename into message + mov byte ptr es:[di],"$" ;terminate byte + cmp rpc_loaded,0 ;have we gotten past rpc load? + je fat_exit ; no, exit + call unload_all ; yes, ensure all xli's unloaded +fat_exit: + mov dx,offset FILERR ;ds:dx => message + jmp pgroup:xcabt ;exit to DOS +fat_err endp + +; FATAL_PRO_ERR +; A protected mode operation has failed. Call pro_error in serror.c to +; output an error message and attempt a scheme-reset. +; a scheme reset. +; +; On entry: +; ax = error number +; bx => function call name +; cx => operation being performed (sw-int, xcall, etc.) +; +pro_err proc near +fatal_pro_err label near + push bp + mov bp,sp ;set up stack for call + push ss + pop ds ;ensure ds = data segment + push ax ;error number + push bx ;function call + push cx ;routine + mov C_fn, offset pgroup:pro_erro + call far ptr far_C ;control will not return here +pro_err endp + + +; XESC +; Handler for the "%xesc" opcode. +; +; On entry: +; AX = length of xesc call (= inst length - 1) +; ES:SI = pointer to bytecode arguments of the %xesc opcode +; +; On exit: +; normal: the VM reg that contained the name string on entry will +; contain the page:offset of the return value; there may +; be side effects in strings that were arguments to %xesc +; BX = 0 (no errors) +; error: BX = error# +; +; Description: +; A buffer is built for an RPC call to the real mode handler for +; an external subroutine call (XCALL). The buffer is built in a +; buffer in the real mode routine as follows: +; +; +----------------------------------------+ +; | Routine name length (1 word) | +; | Routine name (above length) | +; | | +; | Number of XCALL Arguments (1 word) | +; | | +; | Type of Arg1 (1 word) | +; | Arg1 (type dependent) | +; | . | +; | . | +; | . | +; | Type of Argn (1 word) | +; | Argn (type dependent) | +; +----------------------------------------+ +; +; After calling the real mode handler, the buffer will contain +; result info and return values. See the structure "xesc_result" +; for a description of the buffer upon return. +; + +; +; This following data will be allocated locally within xesc +; +local_save struc +; following is used to store return data from xli routines +xesc_status dw ? ; return status +xesc_vtype dw ? ; type of value being returned +xesc_value dw 4 dup (?) ; return value +; following is local data used in building xli call +saved_si dw ? ; segment offset of vm bytecode +saved_es dw ? ; segment address of vm bytecode +first_arg dw ? ; first actual argument +arg_count dw ? ; number of args (len,name are not args) +rvreg dw ? ; vm register to hold return value +local_save ends + +arg_ptr equ saved_si ; alias for current argument pointer +ssr_status equ xesc_status ; ssr return status (will be -1) +ssr_argnum equ xesc_vtype ; argument requested (zero based) by ssr +ssr_len equ xesc_value ; length requested +ssr_offset equ xesc_value+2 ; real mode offset to store arg +ssr_seg equ xesc_value+4 ; real mode segment to store arg +result_buf_len equ saved_si-xesc_status ; length of result buffer + + +xesc proc far + push bp ;save callers bp + sub sp,rvreg+2 ;reserve for local storage + mov rpc_saved_sp,sp ;save off stack pointer + mov bp,sp ; and update BP + + mov xesc_func,1 + lea bx,xesc_err_exit ; Set up error handler for xesc + mov error_return,bx + + mov [bp].saved_es,es ;save segaddr of arguments + inc si ;bump past name to first arg + mov [bp].saved_si,si ; and save + mov [bp].first_arg,si + dec si + + sub ax,2 ;calc # args (not incl. name) + mov [bp].arg_count,ax ; and save + + RESET_REAL_BUFFER_OFFSET ;ensure start at zero + +; +; Move the string name to the real mode buffer +; + xor bh,bh + mov bl,byte ptr es:[si] ;BX is reg# of name string + lea bx,regs[bx] ;VM reg @ + mov [bp].rvreg,bx ; save as return register + mov si,[bx].C_page + cmp ptype[si],STRTYPE*2 ;is it a string? + je xesc_15 ;yes, jump + cmp ptype[si],SYMTYPE*2 ;is it a symbol? + je xesc_10 ;yes, jump + mov ax,XLI_ERR_NAME_BAD_TYPE ;error: name not string, symbol + jmp xesc_err_exit +; +; Warning : DS is not used for the local data segment in the following code +; +xesc_10: + %LoadPage ds,si ;page# in SI -> para# in DS + mov si,ss:[bx].C_disp ;DS:SI is symbol object @ + mov cx,[si].sym_len ;get symbol object length + sub cx,sym_ovhd ;subtract symbol's overhead + add si,sym_ovhd ;skip past overhead + jmp short xesc_25 +xesc_15: %LoadPage ds,si ;page# in SI -> para# in DS + mov si,ss:[bx].C_disp ;DS:DI is string object @ + mov cx,[si].str_len ;get string object length + cmp cx,0 ;is it positive? + jge xesc_20 ;yes, jump; normal string + add cx,str_ovhd*2 ;no, assume short string + ;rather than really long string + ;and make positive +xesc_20: sub cx,str_ovhd ;subtract string's overhead + add si,str_ovhd ;skip past overhead +xesc_25: + push ds + push si ;temp save string ptr + push cx ;and length + + mov ax,ss ;get local data seg + mov ds,ax + + MOVE_ARGS_TO_BUF cx,REAL_MODE_BUFFER,autoincr ;move length to buf + + pop cx + pop si + pop ds ;ds:si => string ptr + + MOVE_TO_REAL_BUF autoincr ;move string to buf + +; +; Warning : DS is not used for the local data segment in the above code +; + mov ax,ss + mov ds,ax ;restore data segment +; +; Move argument count to real mode buffer +; + mov bx,[bp].arg_count + MOVE_ARGS_TO_BUF bx,,autoincr,save ;move #args to buffer + +; +; Move the xesc arguments to the real mode buffer. +; + cmp bx,0 ;any arguments? + je xloop_done ; no, jump +xesc_loop: + les si,dword ptr [bp].arg_ptr ;es:si => argument + inc [bp].saved_si ;bump for next time thru + xor bh,bh + mov bl,byte ptr es:[si] ;pick up arg + lea bx,regs[bx] ;BX is VM reg @ + mov si,[bx].C_page ;get its page# + mov si,ptype[si] ; and type + push si ;save around following +;move type info to buffer + MOVE_ARGS_TO_BUF si,REAL_MODE_BUFFER,autoincr +; Dispatch on argument type + pop si ;restore type # + call cs:word ptr do_arg[si] ;process argument (by type) + dec [bp].arg_count ;any more args left + jnz xesc_loop ; yes, loop +xloop_done: + RESET_REAL_BUFFER_OFFSET ;reset buffer ptr for later +; +; Now issue the RPC call, real routine knows where the buffer is +; + push 0 ;dummy word + push RPCXESC ;RPC REQUEST CODE +xesc_57: + mov dx,sp ;DS:DX = transaction buffer + mov cx,4 + mov bx,cx ;DX = length of result + mov al,rpc_handle + mov ah,RPC ;Issue RPC + int DOS ;Extended Dos func + pop ax ;get return status + mov sp,bp ;dump args off stack + or ax,ax ;error during xesc call? + je normal ; no, continue + cmp ax,XLI_ERR_NO_SUCH_NAME ;calling an unknown xli func? + jne xesc_null_err_exit ; no, return error + mov bx,[bp].rvreg ;load bx with name requested + jmp xesc_err_exit ;and return with error + +; We're back with a return value--unless it's a special service call. +; At this point, ES:DI should point to buffer. +normal: cld + + mov si,sp ;store data on stack (ds:si) + les di,dword ptr REAL_MODE_BUFFER ;address real buffer (es:di) + mov cx,result_buf_len ;cx = length + MOVE_FROM_REAL_BUF ;move return data to local stack + + mov ax,[bp].xesc_status ;get return status + or ax,ax ;Check status + jl ssr ; <0 = SSR + ; 0 = normal return + mov di,[bp].xesc_vtype ;get return value type + cmp di,N_RV*2 ;out of range? + jb xesc_70 ; no, jump + cmp di,RV_ERR*2 ;xli program error? + jne xesc_65 ; no, jump + mov si,bp ; + add si,xesc_value ;DS:SI => return value + mov bx,[bp].rvreg ;bx = return reg address + call do_strval ;go get the error message + mov ax,XLI_ERR_EXTERNAL_ERROR ;ax=error indication + mov bx,[bp].rvreg ;bx = return reg address + jmp xesc_err_exit ;bx=message +xesc_65: + mov ax,XLI_ERR_VALUE_BAD_TYPE ;unkown return type + jmp xesc_null_err_exit ;return error +xesc_70: + mov si,bp + add si,xesc_value ;DS:SI => return value + mov bx,[bp].rvreg ;bx = return reg address + call cs:word ptr do_val[di] ;process return value + mov ax,0 ;AX=0 says no errors + +xesc_null_err_exit: + lea bx,nil_reg ;"nil irritant" for some errors +; ax = error indicator (0 = no error), bx=irritant +xesc_err_exit label near + mov cx,mem_entry ;any entries in mem_table? + jcxz xesc_ex10 ;no, jump + push ax ;tempsave error indicators + push bx + xor bx,bx + mov mem_entry,bx ;see if any real mode segments +xesc_ex05: + mov es,mem_table[bx] ;get entry in mem_table + mov ax,DELETE_SEG ;delete the real mode segment + int dos + jnc xesc_ex07 + mov bx,offset dl_seg + mov cx,offset xli_txt + jmp fatal_pro_err ;control will not return here +xesc_ex07: + inc bx + inc bx ;address next entry + loop xesc_ex05 ;go release next one + pop bx ;restore error indicators + pop ax +; at this point, ax = error number, bx = irritant (if error) +xesc_ex10: + mov sp,rpc_saved_sp ;clean up stack + add sp,rvreg+2 + pop bp ;restore callers bp + ret ;return +; SSR +; A real procedure has issued a System Service Request (SSR). Currently, +; this means to pass a string to the real procedure. The result buffer +; indicates the argument from the %xesc call requested (0 based), the +; length of the string, and the real mode segment/offset to place the +; string. This routine copies the data into the real routine's address +; space, and returns. +; + +ssr label near + mov si,[bp].first_arg ;arg list pointer + add si,[bp].ssr_argnum ;now address arg desired + mov es,[bp].saved_es ;ES:SI addresses the arg + mov bl,byte ptr es:[si] ;get reg # + xor bh,bh + lea bx,regs[bx] ;BX is reg@ + + mov si,[bx].C_disp ;si = string object offset + mov bx,[bx].C_page ;bx = string object page # + %LoadPage es,bx ;es:si => string object + inc si ;skip over tag + cld + lods word ptr es:[si] ;get string's length + cmp ax,0 ;a short string? + jge ss_5 ;no, jump + add ax,str_ovhd*2 ;yes +ss_5: sub ax,str_ovhd ;subtract off overhead +; +; es:si => string, ax = length +; + mov dx,[bp].ssr_len ;get length of dest string + or dx,dx ;if non-zero + jnz ss_10 ; then jump +; +; A length of zero indicates that the xli routine wants to address far +; strings. Allocate real memory and put the real segment address into +; the transaction buffer. PRO2REAL will move the string to real memory. +; The real memory selector is saved in mem_table, and released when we +; exit this xesc call. +; + push ax ;save length + push si + push es ;save ptr to string + xor cx,cx + mov dx,ax ;cx:dx = string length + mov ax,ALLOC_REAL ;Allocate real segment + int dos ;Allocate real segment + jnc ss_07 + mov bx,offset al_seg + mov cx,offset xli_txt + jmp fatal_pro_err ;control will not return here +ss_07: +; ax=selector, bx=para address + push ax ;tempsave selector + les di,dword ptr REAL_MODE_BUFFER + add di,ssr_seg ;address of real buffer (es:di) + MOVE_ARGS_TO_BUF bx ;save segment to real mode + mov dx,cx ;dx = length + pop ax ;restore selector +; save real memory selector in table + mov bx,mem_entry ;get entry number + inc mem_entry ;bump number of entries + shl bx,1 ;index into memory table + mov mem_table[bx],ax ;save selector there + + pop es + pop di ;es:di => string to copy + pop dx ;restore length + jmp ss_25 +; We have a string length here, set ds:si to point to the real memory +; address. PRO2REAL will create a real window over this area, and copy +; the string to it. +ss_10: + cmp ax,dx ;string len >= buffer len? + jae ss_20 ;yes, jump + mov dx,ax ;dx = #chars to copy +ss_20: + mov di,si ;es:di = string to copy + mov si,bp + add si,ssr_offset ;ds:si => real memory address + xor ax,ax ;use ds:si to map address +ss_25: + call pro2real ;copy to real memory + + push cx + push RPCXLISSR + jmp xesc_57 + +xesc endp + + +; SOFTINT +; Handler for the "software interrupt" +; +; Use: +; call SOFTINT 7,op,intnum,return-type,ax,bx,cx,dx +; where all arguments are pcs registers +; +; On exit: +; The first register will contain the returned value +; +; Description: +; All args are interrogated to determine the length of a buffer +; required to hold the args. A buffer is allocated in real mode +; (via function E8), the args are then copied into the buffer, +; and the software interrupt is issued. Upon return, the return +; value is processed, the buffer is deallocated, and the first +; register is set with the return value. + +; +; This following data will be allocated locally within SWINT +; +local_save struc +; Following is the machine state block for Issue Real Interrupt request +msb_ax dw ? ; ax register for interrupt +msb_bx dw ? ; bx register for interrupt +msb_cx dw ? ; cx register for interrupt +msb_dx dw ? ; dx register for interrupt +msb_si dw ? ; si register for interrupt +msb_di dw ? ; di register for interrupt +msb_flags dw ? ; flags register for interrupt +msb_ds dw ? ; ds register for interrupt +msb_es dw ? ; es register for interrupt +; The following local data contains ptrs into the real segment +selector dw ? ; selector for real segment +buf_ptr dw ? ; local pointer into real segment +msb_ptr dw ? ; local pointer into msb +stop dw ? ; temp data +work_spc dd ? ; temp working storage +; Following definitions define the stack upon call +caller_bp dw ? ; callers bp +farret dd ? ; far return address +dummy dw ? ; %esc first arg = # operands +arg4 dw ? ; arg4 = dx +arg3 dw ? ; arg4 = cx +arg2 dw ? ; arg4 = bx +arg1 dw ? ; arg4 = ax +ret_type dw ? ; return type +intnum dw ? ; interrupt number +op dw ? ; op-code +local_save ends + +softint proc far + push bp ;save callers bp + sub sp,caller_bp ;allocate local storage + mov bp,sp ;and update BP + + and xesc_func,0 ;note sw-int + lea bx,swi_err_exit ;error handler for sw-int + mov error_return,bx + +; Sum up the space required to hold all the arguments + + mov si,bp + add si,arg4-2 ;SI => args + mov [bp].stop,si ;save for later + mov di,bp + add di,msb_dx ;DI => regs in msb + mov cx,4 ;CX = number of args + xor dx,dx ;DX = space required +sum_spc: + push di ;temp save di + add si,2 ;address arg + mov bx,[si] ;get vm reg + mov di,[bx].C_page ;get its page# + cmp ptype[di],STRTYPE*2 ;Is it a string? + jne sum_010 ; no, jump + %LoadPage es,di ; yes, + mov di,[bx].C_disp ; es:di => string + inc di ; skip tag + mov ax,es:[di] ; get string object length + cmp ax,0 ; is it positive? + jge sum_005 ; yes, jump; normal string + add ax,str_ovhd*2 ; no, short string +sum_005: sub ax,str_ovhd ; subtract overhead + inc ax ; add 1 for null terminator + jmp short sum_020 +sum_010: + mov ax,4 ;non-string at least 4 bytes + cmp ptype[di],FLOTYPE*2 ;floating point object? + jne sum_020 ; no, jump + add ax,4 ; yes, floats are 8 bytes +sum_020: + pop di ;msb register ptr + mov ds:[di],ax ; save length of object + sub di,2 ; next msb register ptr + add dx,ax ;sum space required + loop sum_spc ;and loop + +; CX:DX = space required to buffer the args, SI => arg 1 at this point + + mov ax,ALLOC_REAL ;Create real segment + int DOS ;Extended Dos Function request + jnc swi_07 + mov bx,offset al_seg + mov cx,offset swi_txt + jmp fatal_pro_err ;control will not return here +swi_07: + mov [bp].selector,ax ;save segment selector + mov es,ax ;es = real buffer selector + mov [bp].msb_ds,bx ;save para address in msb + mov [bp].msb_es,bx ;save para address in msb + mov [bp].buf_ptr,0 ;pointer within real segment + mov [bp].msb_ptr,bp ;pointer into msb regs + +; Move each arg into the buffer, SI => arg1 at this point +; +swi_020: + cmp si,[bp].stop ;all args processed? + je swi_025 ; yes, jump + + std + lods word ptr [si] ;pick up arg + mov bx,ax ;save in BX + + mov di,[bp].msb_ptr ;di = ptr to reg in msb + add [bp].msb_ptr,2 ; set for next time + mov cx,ds:[di] ;cx = length of object + mov ax,[bp].buf_ptr ;ax = ptr into buffer + add [bp].buf_ptr,cx ; set for next time + mov ds:[di],ax ;update msb reg with buf ptr + mov di,ax ;es:di => buffer + +; Dispatch on argument type + push si ;tempsave arg ptr + mov si,[bx].C_page ;get page# + mov si,ptype[si] ; and type +; BX=page #, CX=length, ES:DI=>buffer + call cs:word ptr do_arg[si] ;Handle each object. + pop si ;restore arg ptr + jmp swi_020 + +; At this time all args are in the buffer, Issue the sofware interrupt + +swi_025: + cld + mov bx,[bp].intnum ;get reg holding int + mov ax,[bx].C_disp ;AL = interrupt number + mov dx,bp ;DS:DX => machine state block + mov bx,msb_es+2 ;# bytes which may change + mov ah,REAL_INTRP ;AH = Issue Real Interrupt + int DOS ;Extended Dos Function Request + jnc swi_27 + mov bx,offset rl_int + mov cx,offset swi_txt + jmp fatal_pro_err ;control will not return here +swi_27: +; We're back from software interrupt, lets get return value + + mov bx,[bp].ret_type ;get vm reg + mov di,[bx].C_disp + shl di,1 ;make index into valu table + cmp di,N_RV*2 ;return value out of range? + jb swi_070 + ;bx = reg holding return type + mov ax,SWI_ERR_VALUE_BAD_TYPE ;ax = error indicator + jmp swi_err_exit +swi_070: +; now go convert the return values + mov si,bp ;ds:si => address of ret value + mov bx,[bp].op ;bx = return register + call cs:word ptr do_val[di] ;handle one type of return value + mov ax,0 ;AX=0 says no errors +; ax= error indicator (if nonzero, bx = irritant) +swi_err_exit label near + push ax ;push error number + push bx ;push irritant + mov es,[bp].selector + mov ax,DELETE_SEG ;Delete Real Segment + int DOS ;Extended Dos Function + jnc swi_077 + mov bx,offset dl_seg + mov cx,offset swi_txt + jmp fatal_pro_err ;control will not return here +swi_077: + pop cx ;cx = irritant + pop ax ;ax = error indication + mov bx,ax ; move to bx + dec bx ; form index + js swi_ret ;negative - no error + shl bx,1 ;form index + mov bx,swi_errs[bx] ;bx => error message + mov ax,1 ;note non-restartable +; ax= error indicator (if nonzero bx=message address, cx = irritant) +swi_ret: + mov sp,bp + add sp,caller_bp + pop bp + ret +softint endp + + + subttl Code segment: Copy arguments to xfer buffer + page + + +;; Jump tables to handle arguments to the %xesc call +; indexed by argument type (standard PCS type tag) +do_arg dw do_lstarg ;0=list (#f only) + dw do_fixarg ;1=fixnum + dw do_floarg ;2=flonum + dw do_bigarg ;3=bignum + dw do_symarg ;4=symbol (#t only) + dw do_strarg ;5=string + dw do_errarg ;6 the rest we don't care about + dw do_errarg ;7 + dw do_errarg ;8 + dw do_errarg ;9 + dw do_errarg ;10 + dw do_errarg ;11 + dw do_errarg ;12 + dw do_errarg ;13 + dw do_errarg ;14 + dw do_errarg ;15 + +; On entry to all the argument handler routines: +; ES:DI = pointer to real mode buffer to store data +; BX = address of VM reg with page:offset of Scheme object +; SI = Type of operand code +; +; On exit: +; CX = number of bytes moved to the buffer pointed to by ES:DI + +; +; Process list argument +; +do_lstarg label near ;looking for false only + cmp [bx].C_page,NIL_PAGE*2 + je do_lst01 + jmp do_errarg +do_lst01: + xor ax,ax + jmp do_log + +; +; Process fixnum argument +; +do_fixarg label near + mov ax,[bx].C_disp ;get the fixnum data + shl ax,1 ;deal with sign bit + sar ax,1 ;ax = 16-bit signed int +; True and false are treated as the numbers 1 and 0, respectively. +; Boolean-argument processing merges into integer processing at this point. +do_log: cwd ;dx:ax is 32-bit signed int + MOVE_ARGS_TO_BUF ,,autoincr,save + ret ;and return +; +; Process float argument +; +do_floarg label near + push ds ;preserve data seg + + mov si,[bx].C_page ;get float's page # + mov ax,[bx].C_disp ; and offset + %LoadPage ds,si + mov si,ax ;ds:si => float + inc si ;bump past header + mov cx,8 ;cx = length of float + MOVE_TO_REAL_BUF autoincr,save ;move float to buffer + pop ds ;restore data seg + ret ;and return + +; +; Process bignum argument +; +do_bigarg label near +; Stage the conversion to longint on the stack + sub sp,4 ;allocate stack space for long + mov ax,sp ;note its address +; ok to add to stack here because we've reserved space above. + push es ;save regs around call + push di + push bp + mov bp,sp + push bx ;push VM reg@ + push ax ;push buffer@ + mov C_fn,offset pgroup:int2long ;convert bignum to long + call far ptr far_C + pop bx ;dump buffer@ + pop bx ;restore VM reg@ + pop bp ;restore bp + pop di ; di + pop es ; es +; above cleans stack up from calling C routine + cmp ax,0 ;did bignum convert OK? + je do_big5 ;yes, jump +; there was an error in converting the number + mov ax,XLI_ERR_BIG_TO_32_BITS ;ax = error # (default xli) + cmp xesc_func,0 ;performing xli function? + jne do_bigerr ; yes, jump + mov ax,SWI_ERR_BIG_TO_32_BITS ;ax = error # (for sw-int) +; ax=error number, bx=irritant +do_bigerr: + jmp error_return +do_big5: + mov si,sp ;ds:si => long int + mov cx,8 ;cx = length + MOVE_TO_REAL_BUF autoincr,save ;move float to buffer + add sp,4 ;clean up stack + ret ;and return + +; +; Process symbol argument +; +do_symarg label near ;looking for true only + cmp [bx].C_page,T_PAGE*2 + jne do_errarg + cmp [bx].C_disp,T_DISP + jne do_errarg + mov ax,1 + jmp do_log + +; +; Process string arguments +; +do_strarg label near + or xesc_func,0 ;doing xesc? + jz swi_strarg ; no, jump + MOVE_ARGS_TO_BUF <-1>,,autoincr,save ; yes, indicate string + ret +swi_strarg: ;move string to swint buffer + push ds ;preserve regs + push si + mov ax,[bx].C_disp ;get offset + mov si,[bx].C_page ;get page # + %LoadPage ds,si + mov si,ax ;ds:si => string + inc si ;skip tag + cld + lods word ptr [si] ;get length + or ax,ax ;is it positive? + jge swi_str05 ;yes, jump; normal string + add ax,str_ovhd*2 ;no, short string +swi_str05: + sub ax,str_ovhd ;subtract overhead + mov cx,ax ;CX = length of string + MOVE_TO_REAL_BUF autoincr ;move string across + mov ax,ss + mov ds,ax + push cx ;save # bytes just written + MOVE_BYTE_TO_BUF 0,,autoincr ;write out null terminator + pop cx + inc cx ;cx = total # bytes written + pop si ;restore preserved regs + pop ds + ret + +do_errarg label near + mov ax,XLI_ERR_ARGN_BAD_TYPE ;ax = error # (default xli) + cmp xesc_func,0 ;performing xli function? + jne do_errerr ; yes, jump + mov ax,SWI_ERR_ARGN_BAD_TYPE ;ax = error # (for sw-int) +; ax = error number, bx=irritant +do_errerr: + jmp error_return + + + subttl Code segment: Copy return value back into Scheme + page + +;; Jump tables to handle values returned from the real routine +; indexed by value type (SW-INT return types) +do_val dw do_intval ;0=integer + dw do_TFval ;1=true/false + dw do_strval ;2=string + dw do_floval ;3=flonum + + +; On entry to all the value handler routines: +; BX = result register address +; DS:SI = pointer to return value + +; +; Process integer return value +; +do_intval proc near +do_int10: + push bp + mov bp,sp ;get BP set for C call + or xesc_func,0 ;doing xesc? + jnz doint_05 ; yes, jump + push [si] ;si=> msb_ax on stack. remember + push [si]+2 ;lattice's return conventions + jmp doint_07 +doint_05: push [si]+2 ;push longint + push [si] +doint_07: push bx ;push vm reg address + mov C_fn,offset pgroup:long2int ;allocate integer + call far ptr far_C ;C longint -> PCS integer + ;(bignum or fixnum) + mov sp,bp ;pop C args + pop bp ;restore callers bp + ret ; and return +do_intval endp + +; +; Process true/false return value +; +do_TFval proc near + mov cx,0 + or xesc_func,0 ;doing xesc? + jnz dotf_05 ; yes, jump + mov ax,[si]+2 ;si=> msb_ax on stack. remember + jmp dotf_07 ;lattice's return convention +dotf_05: mov ax,[si] ;get value +dotf_07: or ax,ax ;zero? + jz do_TF10 ; yes (false object) + mov ax,T_DISP ; no (true object) + mov cx,T_PAGE*2 +do_TF10: + mov [bx].C_disp,ax + mov [bx].C_page,cx + ret +do_TFval endp + +; +; Process float return value +; +do_floval proc near + push bp + mov bp,sp + or xesc_func,0 ;doing xesc? + jnz doflo_05 ; yes, jump + push [si] ;si=> msb_ax on stack. remember + push [si]+2 ;lattice's return conventions + push [si]+4 ;and push args appropriately. + push [si]+6 + jmp doflo_07 +doflo_05: push [si]+6 ;push float values + push [si]+4 + push [si]+2 + push [si] +doflo_07: push bx ;push vm return reg + mov C_fn,offset pgroup:alloc_fl ;allocate float + call far ptr far_C ;C double -> PCS flonum + mov sp,bp ;pop args from stack + pop bp + ret +do_floval endp + +; +; Process string return values +; +do_strval proc near + or xesc_func,0 ;doing xesc? + jz swi_strval ; no, jump +; +; Do it for xli +; + push bp + mov bp,sp + + mov cx,[si] ;get string length + cmp cx,16380 ;string length short enough? + jbe do_stv15 ;yes, jump + mov cx,16380 ;no, truncate at max +do_stv15: +; allocate the space for the return value string object + push cx ;save length for later + push si ; pointer to buffer + push bx ; return value VM reg + push bp + mov bp,sp ;get BP set for C call + push cx ;push length + push STRTYPE ;push type + push bx ;push return value VM reg @ + mov C_fn,offset pgroup:alloc_bl ;allocate block + call far ptr far_C ;go do it + mov sp,bp ;pop C args + pop bp + pop bx ;return VM reg + mov di,[bx].C_disp + mov bx,[bx].C_page + %LoadPage es,bx + add di,3 ;es:si => destination + pop si + add si,2 ;ds:si => real mode address + pop dx ;dx = length + call real2pro ;xfer from real mem to pro mem + mov sp,bp ;clean up stack + pop bp ;restore caller's bp + ret ;and return +; +; Do it for software interrupt +; +swi_strval: + + push ds ;tempsave ds + mov si,[bp].msb_ax + mov ds,[bp].selector ;DS:SI points to string + + push ss + pop es + mov di,bp + add di,work_spc ;ES:DI => destination + + mov ax,BLOCK_XFER ;grab one byte and test zero + mov cx,1 + mov dx,0FFFFh +swi_str01: + inc dx ;# bytes read + int DOS ;xfer 1 byte + inc si ;next byte to read + cmp byte ptr es:[di],0 ;is it zero? + jne swi_str01 ;no, get next char +swi_stv15: + pop ds ;restore ds + push dx ;save length for later +; +; allocate the space for the return value string object +; + mov ax,[bp].op ;get return vm reg + + push bp ;tempsave around call + mov bp,sp ;get BP set for C call + push dx ;push length + push STRTYPE + push ax ;push vm reg + mov C_fn,offset pgroup:alloc_bl + call far ptr far_C ;allocate string object; + ;"alloc_block" takes care + ;of overhead matters + mov sp,bp ;pop C args + pop bp + + mov bx,[bp].op ;return value VM reg + mov di,[bx].C_disp + mov bx,[bx].C_page + %LoadPage es,bx ;ES:DI is dest object @ + add di,3 ;skip past string's overhead + + mov si,[bp].msb_ax + mov ds,[bp].selector ;DS:SI is string in buffer + pop cx ;CX = length + mov ax,BLOCK_XFER ;copy into scheme heap + int DOS ;Extended Dos function call + + mov ax,ss + mov ds,ax + ret +do_strval endp + + +do_errval proc near + mov ax,XLI_ERR_VALUE_BAD_TYPE + jmp error_return +do_errval endp + + + public pro2real,real2pro,map_real_mem +; REAL2PRO +; +; On entry: +; DS:SI => address of real mode buffer +; ES:DI => scheme heap +; DX = length +; +; On exit: +; CX is number of chars xfered + +real2pro proc near + push ds ; save data segment + call map_real_mem ; create real window (selector in ax) +; Error Checks here + mov cx,dx ; cx = length +; WARNING: DS addresses real memory below + mov ds,ax ; real mode selector + xor si,si ; ds:si = source (real data) + mov ax,BLOCK_XFER ; do block xfer + int DOS + mov ax,ds + mov es,ax ; es = mapped selector + mov ax,DELETE_SEG ; Delete Segment + int DOS + jnc r2p_next + xor bx,bx + mov bl,ss:xesc_func + shl bx,1 + mov cx,ss:which_func[bx] + mov bx,offset dl_seg + jmp fatal_pro_err ;control will not return here +r2p_next: +; WARNING: DS does not address scheme's data segment above + pop ds ; restore data segment + ret +real2pro endp + + +; PRO2REAL +; Copy data from protected mode memory to real mode memory. If ax is +; non-zero, then it already contains a real selector where we can move +; the data - in this case we don't create a real window and delete the +; segment selector after the copy. +; +; On entry: +; if AX = 0 +; then DX = length +; DS:SI => address of real mode buffer +; ES:DI => scheme heap +; else +; AX = selector to real mode buffer +; DX = length +; ES:DI => scheme heap +; +; On exit: +; CX is number of chars xfered + +pro2real proc near + push ds ; callers data segment + push ax ; indicator + push di ; offset to data + or ax,ax ; do we have a selector already? + jnz p2r_010 ; yes, don't create real window (jump) + call map_real_mem ; no, create real window + ; selector returned in ax +; Error Checks here +p2r_010: + mov cx,dx ; cx = length +; WARNING: DS addresses scheme heap below + mov bx,es + mov ds,bx + pop si ; ds:si = source (in scheme heap) + + mov es,ax ; real mode selector + xor di,di ; es:di = destination (in real mode) +mode_xfer: + mov dx,ax ; tempsave selector + mov ax,BLOCK_XFER ; do block xfer + int DOS + pop ax ; restore indicator + or ax,ax ; was a selector passed in? + jnz mode_xf01 ; yes, then don't delete it + mov es,dx ; es = mapped selector + mov ax,DELETE_SEG ; Delete Segment + int DOS + jnc mode_next + xor bx,bx + mov bl,ss:xesc_func + shl bx,1 + mov cx,ss:which_func[bx] + mov bx,offset dl_seg + jmp fatal_pro_err ;control will not return here +mode_next: +; WARNING: DS does not address scheme's data segment above +mode_xf01: + mov ax,ds + mov es,ax ; restore ptr to scheme heap + pop ds ; restore data segment + ret +pro2real endp + +; MAP_REAL_MEM +; Map a real memory address into a selector for use in protected memory. +; +; DS:SI => address of real mode buffer +; DX = length +; +; On exit: +; Carry flag set on error +; AX = selector for real memory or error if carry flag set +; +; Regs used: ax,bx,cx,si - all destroyed + +map_real_mem proc near + ; create real mode window + xor ax,ax + mov cx,4 ; shift count + mov bx,[si]+2 ; bx = real segment address + mov al,bh ; create 32 bit address in SI:BX + shr ax,cl + shl bx,cl ; shift for physical mem calc + add bx,[si] ; add effective memory address + jnc mr_25 + inc ax ; SI:BX = real memory address +mr_25: + mov si,ax ; si:bx = real memory address + xor cx,cx ; CX:DX = length + mov ax,CREATE_WIN ; Create Window function request + int DOS ; Return selector in AX + jnc mr_ret + xor bx,bx + mov bl,ss:xesc_func + shl bx,1 + mov cx,ss:which_func[bx] + mov bx,offset cr_win + jmp fatal_pro_err ;control will not return here +mr_ret: + ret +map_real_mem endp + +progx ends + + + + subttl Prog segment code definitions + page + +prog segment byte public 'PROG' + assume cs:pgroup + extrn next_SP:near,src_err:near + extrn fix_intr:near + public pcinit,set_crtint,reset_crtint,xli_ldall,xli_term,xli_xesc + +; PC_INIT +; Perform initializations, some of which are PC specific. +; +pcinit proc near + call bid_rpc ;bid the real mode code + cmp pcs_sysd,0 ;have we found the system directory? + jz pcini_00 ; no, skip loading of xli + call xli_ldall ; yes, load xli stuff +pcini_00: + call pc_init ;get specific pc info + call fix_intr ;take over interrupts + ret ;return to caller +pcinit endp + + +; The following routines are gateways to routines in the progx segment +; for real procedure calls (RPC) and external language interface (XLI). +; Note that the progx routines are jumped to via the FAR_RPC table, however +; they return to the caller of this routine because we fix up the stack. +; +bid_rpc proc near + mov bx,frpc_bid ;initialize real procedure + jmp rpc_call +pc_init: + mov bx,frpc_init ;get machine type + jmp rpc_call +set_crtint: + mov bx,frpc_setcrt ;set crt interrupt + jmp rpc_call +reset_crtint: + mov bx,frpc_resetcrt ;reset crt interrupt + jmp rpc_call +xli_ldall: + mov bx,frpc_ldall ;load xli files + jmp rpc_call +xli_term: + mov bx,frpc_unld ;unload xli files + jmp rpc_call +xli_xesc: + mov bx,frpc_xesc ;perform xesc + jmp rpc_call +rpc_call: + pop dx ;pop return address + push prog ;push segment return + push dx ;then offset + jmp dword ptr FAR_RPC+[bx] ;jump to progx routine + ret ;we'll never return here +bid_rpc endp + +; Far linkage *from* XLI +; (all the memory allocation routines are written in C). +; The caller of this should have set BP from SP before pushing the C args, +; then restore SP from BP afterwards to remove them from the stack. +; We don't preserve ES across the call. + public far_C +far_C proc far + push ds ;C likes ES=DS + pop es + pop C_retadr ;get far @ off stack so C sees its args + pop C_retadr+2 + call [C_fn] + push C_retadr+2 + push C_retadr + ret ;C returns with return value in AX..DX +far_C endp + +prog ends + + end + \ No newline at end of file diff --git a/probid.asm b/probid.asm new file mode 100644 index 0000000..ef72162 --- /dev/null +++ b/probid.asm @@ -0,0 +1,168 @@ +; +;*************************************** +;* TIPC Scheme Runtime Support * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 5 June 1985 * +;* Last Modification: 15 May 1986 * +;*************************************** + page 60,132 + .286c + + include smmu.mac + +MSDOS equ 021h ; MS-DOS service call interrupt +BIDTASK equ 04Bh ; Load/Execute program + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + extrn _psp:dword ; program segment prefix paragraph address + +cmd_ db "COMSPEC=" +cmd_1 equ $ +ENVPTR dw 0 ; DOS EXEC parameter block +CMDOFF dw 0 ; " +CMDSEG dw 0 ; " +FCB1OFF dw 5Ch ; " +FCB1SEG dw 0 ; " +FCB2OFF dw 6Ch ; " +FCB2SEG dw 0 ; " + +INSTALLED dw 0 ; Whether crt interrupt is installed or not + +data ends + +XGROUP group PROGX +PROGX segment byte public 'PROGX' + assume CS:XGROUP + +;************************************************************************ +;* Bid another Task * +;************************************************************************ + +; +; BP is set up by bid (the caller of this routine) +; +bid_args struc + dw ? ; caller's BP + dw ? ; return address (caller of bid) +bid_file dw ? ; program's file name +bid_parm dw ? ; parameters +free_req dw ? ; requested # of free paragraphs +display dw ? ; Indicates if screen should be disturbed +bid_args ends + + +bid_task proc far + push ES + +; Set up parameter block + mov AX,[BP].bid_parm ; Set up dword pointer to command line + mov CMDOFF,AX + mov CMDSEG,DS + + mov AX,word ptr _psp+2 ; Point to FCBs in program segment prefix + mov FCB1SEG,AX + mov FCB2SEG,AX + + mov ES,AX + mov AX,ES:[02Ch] ; copy current environment ptr to + mov ENVPTR,AX ; parameter area + +; Set ES:BX to address of parameter block + mov AX,DS + mov ES,AX + mov BX,offset ENVPTR + +; Set DS:DX to address of ASCIZ pathname (of file to be loaded) + push DS ; save DS segment register + mov DX,[BP].bid_file + mov DI,DX + cmp byte ptr [di],0 ; check if pt'ed to string is empty + jne bid_it + +; No filename-- bid up a new command interpreter; +; have to search environment for COMSPEC= string + mov ES,ENVPTR ; ES:DI points to 1st string in environment + xor DI,DI + +; Test for end of environment +get_plop: cmp byte ptr ES:[DI],0 ; last entry in environment? + je cmd_err ; if so, COMSPEC= not found + mov SI,offset cmd_ ; load address of comparison string + mov CX,cmd_1-cmd_ ; and length of same + repe cmps cmd_,ES:[DI] ; does this entry begin "COMSPEC="? + je found ; if so, found it! (jump) + xor AX,AX ; clear AX for search + mov CX,-1 ; set CX for maximum length + repne scas byte ptr ES:[DI] ; find \0 which terminates string + jmp get_plop ; loop + +; No command interpreter found +cmd_err: mov AX,10 ; treat as bad-environment error + stc + jmp short get_out + +; Found COMSPEC= +found: mov DX,DI ; DS:DX is ptr to command interpreter + push DS ; (swap DS and ES) + push ES + pop DS + pop ES + +; issue load task function call +bid_it: + xor AL,AL ; load and execute condition + mov AH,BIDTASK + ; load "load and execute" ftn id + int MSDOS ; perform service call +get_out: pop DS ; restore DS segment register + jc exit ; branch if error in bidding task + xor AX,AX ; indicate no error +exit: + pop ES ; restore ES segment register + ret ; return to caller +bid_task endp + + +PROGX ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + extrn unfixint:near,fix_intr:near + extrn zcuron:near,zcuroff:near + extrn set_crtint:near,reset_crtint:near + + + public bid +bid proc near + push bp + mov bp,sp ;address local arguments + + call unfixint ;reset shift-break vector + call zcuron ;turn the cursor back on + cmp [bp].display,0 ;can we disturb the screen? + je no_install ; yes, jump + call set_crtint ; no, take over crt interrupt +no_install: + call bid_task ;go bid the task + push AX ;save its error return code + + cmp [bp].display,0 ;crt interrupt taken over + je no_uninstall ; no, jump + call reset_crtint ; yes, reset the crt interrupt +no_uninstall: + call zcuroff ;turn the cursor back off + call fix_intr ;set shift-break vector + pop AX ;restore error code + pop bp ;dump args from stack + ret ;return to caller +bid endp +prog ends + end + \ No newline at end of file diff --git a/prointrp.asm b/prointrp.asm new file mode 100644 index 0000000..5429e24 --- /dev/null +++ b/prointrp.asm @@ -0,0 +1,202 @@ +; =====> PROINTRP.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* Special Keyboard Handlers * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: Feb 1988 * +;* * +;* This file is basically INTRUP.ASM * +;* modified to run in protected mode * +;* under AI Architects OSx86. * +;* * +;*************************************** + .286c + page 66,132 + include dos.mac + include pcmake.equ + include smmu.mac ; Protected mode Macros + +DOS equ 021h ; Dos function request +EXT_ERR equ 059h ; Dos get extended error +GET_VEC equ 035h ; Dos get interrupt vector +SET_VEC equ 025h ; Dos set interrupt vector +SET_AIA_VEC equ 0E4h ; AIA set interrupt vector + +TI_PBI equ 05Dh ; TI Program Break Interrupt +IBM_PBI equ 01Bh ; IBM Program Break Interrupt +ERR_INT equ 024h ; Fatal error abort address +CTRLC_INT equ 023h ; Control C exit interrupt + + + DSEG + extrn PC_MAKE:word + ENDDS + +PGROUP GROUP PROG +PROG SEGMENT BYTE PUBLIC 'PROG' + ASSUME CS:PGROUP + extrn shft%brk:far +PROG ends + +XGROUP GROUP PROGX +PROGX SEGMENT BYTE PUBLIC 'PROGX' + ASSUME CS:XGROUP,DS:DGROUP + + ; Sorry guys, but this has gotta be in CS: +kbmi_off dw ? ; Keyboard Mapping Interrupt (offset) +kbmi_seg dw ? ; Keyboard Mapping Interrupt (segment) +;****************** + + public PROG_BRK +PROG_BRK proc far ; Handler for Keynoard Break Interrupt + push ax ; Save keystroke across call + call PGROUP:shft%brk ; Flag to force debugger on next VM inst + pop ax ; Restore keystroke + mov ax,0FFh ; Ignore keystroke (IBM'll ignore this) + stc ; Tell TI keyboard DSR no key was pressd + ; again, IBM BIOS won't care about this. + iret ; interrupt return +PROG_BRK endp + +;****************** + public CTLC_INT +CTLC_INT proc far ; Handle detection of CTRL-C (INT 23H) + iret ; Just return like nothing happened 'cept + ; that a ^C trio is displayed. +CTLC_INT endp + +;******************* + public FAT_ERR +FAT_ERR proc far ; Handle for fatal error interrupt (24H) + mov ax,di ;di = err number. add 19 to form err number + add ax,19 ;you would get from Get Extended Error (59h) + iret ;just return for now +comment ~ +; +; First release of AI Architect's OSx86 didn't support fatal error +; interrupts as specified by DOS. Also, couldn't issue Get Extended +; Error (Dos function 59h) from within here. Above code will have +; to suffice for now. +; + ; remove ip,cs, and flags of system regs from int 24h + pop AX + pop AX + pop AX + + ; get extended error codes + xor BX,BX + mov AH,EXT_ERR + int DOS ; Extended Error Code returned in AX + + ; restore user registers at time of original function request 21h + pop BX ; Ignore old AX + pop BX + pop CX + pop DX + pop SI + pop DI + pop BP + pop DS + pop ES + + ; Set the carry bit in the caller's flags and return + ; The original dos requestor should see that carry is set and + ; that ax contains the error code + + or byte ptr [BP-02], CARY_FLG + iret +~ + +FAT_ERR endp + +;******************* +; Reassign program break interrupt (5Dh=ti, 1Bh=ibm), and "fix" Dos's +; CTRL-C Exit int (23h) + public fix%intr +fix%intr proc far + push es ;tempsave off some regs + push dx + push bx + push ax +; +; WARNING: DS does not point to the local data segment below +; + mov ax,cs + mov ds,ax ;set ds=cs for dos calls below + +; take over program break interrupt + ;no need to get interrupt vector + ;since AIA will clean up on exit + mov ah,SET_VEC ;ah = set interrupt vector + mov al,IBM_PBI ;al = ibm program break interrupt + cmp SS:PC_MAKE,TIPC ;if not running on a TIPC + jne short fix_010 ; then jump + mov al,TI_PBI ; else set TI program break interrupt +fix_010: + mov dx,offset PROG_BRK ;ds:ax => interrupt handler + int DOS ;take over the handler + +; take over ctl-c interrupt + mov ah,SET_VEC ;ah = set interrupt vector + mov al,CTRLC_INT ;al = CTRL-C Interrupt (23H) + mov dx,offset PROG_BRK ;ds:ax => interrupt handler + int DOS ;take over the handler + +; take over fatal error interrupt + mov ah,SET_VEC ;ah = set interrupt vector + mov al,ERR_INT ;al = Fatal error interrupt + mov dx,offset FAT_ERR ;ds:dx => interrupt handler + int DOS ;take over handler + + mov ax,ss ;restore local data seg + mov ds,ax +; +; WARNING: DS does not point to the local data segment above +; + pop ax ;restore saved regs + pop bx + pop dx + pop es + ret ;get the heck outta here +fix%intr endp + +;****************** +; Restore Keyboard Mapping Interrupt (5BH) +; (DOS should take care of 23H) + public unfix% +unfix% proc far + +; +; We don't do anything cuz AI Architects OSx86 will clean up upon exit. +; However, we'll leave this dummy routine here in case something pops +; up in the future +; + ret ; Get the heck outta here +unfix% endp +PROGX ends + +;********************************************************************** +;* Link routines * +;********************************************************************** +PROG SEGMENT BYTE PUBLIC 'PROG' + ASSUME CS:PGROUP + Public fix_intr, unfixint + +fix_intr proc near + call fix%intr + ret +fix_intr endp + +unfixint proc near + call unfix% + ret +unfixint endp +prog ends + end + + end + \ No newline at end of file diff --git a/proio.asm b/proio.asm new file mode 100644 index 0000000..802fe96 --- /dev/null +++ b/proio.asm @@ -0,0 +1,1210 @@ +; =====> PROIO.ASM +;******************************************************** +;* Scheme Runtime Support * +;* Low level I/O Support Routines * +;* * +;* (C) Copyright 1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 09 November 1987 * +;* Last Modification: * +;******************************************************** + page 60,132 + .286c + include sinterp.arg + include memtype.equ + include scheme.equ + include pcmake.equ + include rpc.equ + include realio.equ + include xli_pro.mac + +; +; local equates +; +EXT_ERR equ 059h ;get extended error +TI_CRT equ 049h ;ti video bios interrupt +IBM_CRT equ 010h ;ibm video bios interrupt + +CURSMASK equ 10011111b ;zeros are the bits that disable cursor +NOCURSOR equ 00100000b ;byte mask to disable cursor + +;------------------------------------------------------------------------------ +; +; Data Definitions +; +;------------------------------------------------------------------------------- + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +;from xli_pro.asm + extrn rpc_handle:byte + extrn REAL_MODE_BUFFER:dword + extrn REAL_BUF_OFFSET:word,REAL_BUF_SELECTOR:word + extrn REAL_BUF_PARA:word,REAL_BUF_TOP:WORD +;from ??? + extrn port_pg:word,port_ds:word,port_r:dword +;from proio.asm + extrn char_hgt:word,cur_off:word +;from prowin.asm + extrn MAX_ROWS:byte,MAX_COLS:byte + + public zapcurs +zapcurs dw 0 ; for disabling cursor altogether +curs_sav dw 400Ch ; Cache for cursor size + + +local_pds dw 0 ; Local copy of port disp +local_ppg dw 0 ; Local copy of port page + + public pro_msb +pro_msb dw 0,0,0,0,0,0,0,0,0 ; Machine State Block for crt_dsr + +sfp_err db "SET-FILE-POSITION!",0 + +; +; Graphics are implemented via the RPC mechanism, the following data +; structures support the %graphics primitives. +; + public vid_mode +vid_mode dw 3 +graphic_go db 3,0,0,0,1,1,0,0,0 ; graphics functions which return vals +m_graph db "%GRAPHICS",0 + +data ends + + +;------------------------------------------------------------------------------ +; +; Code Definitions +; +;------------------------------------------------------------------------------- + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + + extrn next_sp:near, src_err:near + +;************************************************************************ +;* Generate a Bell Character * +;* * +;* Purpose: To generate a "bell character" (i.e., make a noise) to * +;* simulate the effect of outputting a bell character * +;* (control-G) in the output stream. * +;* * +;* Calling Sequence: zbell(); * +;* * +;* Input Parameters: None. * +;* * +;* Output Parameters: None. * +;* * +;************************************************************************ +no_args struc + dw ? ; caller's BP + dw ? ; return address +no_arg dw ? ; designates no args on stack +no_args ends + public zbell +zbell proc near + push bp + mov bp,sp + REALIO REAL_BELL,no_arg,no_arg,continue + pop bp + ret +zbell endp + +;************************************************************************ +;* Clear a Window * +;************************************************************************ +zc_args struc + dw ? ; caller's BP + dw ? ; return address +zc_row dw ? ; upper left hand corner row number +zc_col dw ? ; upper left hand corner column number +zc_nrows dw ? ; number of rows +zc_len dw ? ; line length (number of characters) +zc_attrib dw ? ; character attributes +zc_args ends + + public zclear +zclear proc near + push BP ; save caller's BP + mov BP,SP + pusha + REALIO REAL_CLEAR,zc_row,zc_attrib,continue + popa + pop bp + ret +zclear endp + +;************************************************************************ +;* Draw Border * +;************************************************************************ +zb_args struc + dw ? ; caller's BP + dw ? ; return address +zb_line dw ? ; upper left corner line number +zb_col dw ? ; upper left corner column number +zb_nlines dw ? ; number of lines +zb_ncols dw ? ; number of columns +zb_battr dw ? ; border attributes +zb_label dw ? ; pointer to label text +zb_args ends + + public zborder +zborder proc near + push bp + mov bp,sp + mov si,[bp].zb_label ;ds:si => label + cmp byte ptr [si],0 ;is it null? + jne zb_010 ; no, jump + mov [bp].zb_label,0 ; yes, note null + jmp zb_020 ; and skip +zb_010: + mov ax,REAL_BUF_PARA + mov [bp].zb_label,ax ;seg addr of real buffer +;determine length of label + xor ax,ax + xor cx,cx ;hold count +zb_loop: + inc cx + lodsb + cmp ah,al + jnz zb_loop + sub si,cx ;ds:si => label +;move label to real mode buffer @ address 0 + les di,REAL_MODE_BUFFER ;es:si => real buffer + xor di,di + mov ax,BLOCK_XFER + int DOS + push ds + pop es +;now do the real mode I/O call +zb_020: + REALIO REAL_BORDER zb_line,zb_label,continue + pop bp + ret +zborder endp + +;************************************************************************ +;* Save Screen Contents * +;* * +;* Purpose: To save a rectangular region of the CRT in a string data * +;* object. * +;* * +;* Calling Sequence: save_scr(str_reg, ul_row, ul_col, n_rows, ncols) * +;* where str_reg - pointer to string data object * +;* which is to receive the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* saved * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* saved * +;* n_rows - number of rows in the region to * +;* be saved * +;* n_cols - number of columns in the region * +;* to be saved * +;************************************************************************ +sv_args struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +sv_str dw ? ; address of register pointing to string +sv_ulrow dw ? ; upper left hand corner's row number +sv_ulcol dw ? ; upper left hand corner's column number +sv_nrow dw ? ; number of rows +sv_ncol dw ? ; number of columns +sv_args ends + + public save_scr +save_scr proc near + push es + push bp + mov bp,sp + + push [bp].sv_str ;save register for later + mov ax,REAL_BUF_PARA + mov [bp].sv_str,ax ;seg addr of real mode buffer + + REALIO REAL_SAVESCR,sv_str,sv_ncol + + pop bx ;restore register ptr + mov di,[bx].C_disp + mov bx,[bx].C_page + loadPage es,bx + add di,BLK_OVHD ;es:di => string + + mov ax,[bp].sv_ncol ;determine # chars to copy + mul [bp].sv_nrow + mov cx,2 + mul cx + add ax,2 ;add for row/col info + mov cx,ax + + mov ax,REAL_BUF_SELECTOR + mov ds,ax + xor si,si ;ds:si => real mode buffer + mov AX,BLOCK_XFER ;move real string into heap + int dos + + mov bx,ss ;restore local data seg + mov ds,bx + pop bp ;restore regs + pop es + ret ;return +save_scr endp + +;************************************************************************ +;* Restore Screen Contents * +;* * +;* Purpose: To restore a rectangular region of the CRT from a string * +;* data object. * +;* * +;* Calling Sequence: rest_scr(str_reg, ul_row, ul_col) * +;* where str_reg - pointer to string data object * +;* which contains the screen * +;* contents * +;* ul_row - row number of the upper left * +;* corner of the region to be * +;* restored * +;* ul_col - column number of the upper left * +;* corner of the region to be * +;* restored * +;************************************************************************ +rs_args struc + dw ? ; caller's BP + dw ? ; caller's ES + dw ? ; return address +rs_str dw ? ; address of register pointing to string +rs_ulrow dw ? ; upper left hand corner's row number +rs_ulcol dw ? ; upper left hand corner's column number +rs_mrow dw ? ; number of rows in new window +rs_mcol dw ? ; number of columns in new window +rs_args ends + + public rest_scr +rest_scr proc near + push es + push bp + mov bp,sp + + mov bx,[bp].rs_str ;register holding string ptr + mov si,[bx].C_disp + mov bx,[bx].C_page + loadpage ds,bx + mov cx,word ptr ds:[si]+1 ;cx = string length + add si,BLK_OVHD ;ds:si => string object + mov es,ss:REAL_BUF_SELECTOR + xor di,di ;es:di => real mode buffer + mov ax,BLOCK_XFER + int dos + + mov ax,ss + mov ds,ax ;restore data seg + + mov ax,REAL_BUF_PARA ;replace string reg with addr + mov [bp].rs_str,ax ;of real mode buffer + + REALIO REAL_RESTSCR,rs_str,rs_mcol,continue + + pop bp + pop es + ret +rest_scr endp + +;************************************************************************ +;* Cursor On * +;************************************************************************ + public zcuron +zcuron proc near + cmp zapcurs,0 ; if cursor disabled + jne zcon_ret ; then return + mov cx,curs_sav ; attributes for cursor on + mov ah,01h ; load "set cursor type" code + call far ptr crt_dsr ; turn the cursor on +zcon_ret: + ret ; return to caller +zcuron endp + +;************************************************************************ +;* Cursor Off * +;************************************************************************ + public zcuroff +zcuroff proc near + push bp + mov bp,sp + + call ega_curs + + mov ah,03 + xor bh,bh ;IBM page number/must be 0 for graphics mode + call far ptr crt_dsr ;get the cursor position/mode + cmp zapcurs,0 ; if cursor disabled + jne zcoff_01 ; then jump + mov curs_sav,cx ;save it for restoration +zcoff_01: + and ch,CURSMASK ;mask off bits to select cursor type + or ch,NOCURSOR ;disables cursor (turns it off) + mov ah,01h ;load "set cursor type" code + call far ptr crt_dsr ;turn the cursor off + pop bp + ret ;return to caller +zcuroff endp + +;************************************************************************ +;* Put Cursor * +;************************************************************************ +zpc_args struc + dw ? ; caller's BP + dw ? ; return address +zpc_row dw ? ; upper left hand corner row number +zpc_col dw ? ; upper left hand corner column number +zpc_args ends + public zputcur +zputcur proc near + push bp ; save caller's BP + mov bp,sp +; put cursor in desired location + mov dh,byte ptr [bp].zpc_col ;load column number + mov dl,byte ptr [bp].zpc_row ;load row number + xor bh,bh ;IBMism: page number (0 if in graphics mode) + mov ah,02H ;load "put cursor" code + call far ptr crt_dsr ;position the cursor (DSR swaps DH/DL) + call ega_curs ;display cursor for ega mode +; Return to caller + pop bp ; restore caller's BP + ret ; return +zputcur endp + +;************************************************************************ +;* Output Character To Window * +;************************************************************************ +zp_args struc + dw ? ; caller's BP + dw ? ; return address +zp_line dw ? ; cursor position - line number +zp_col dw ? ; cursor position - column number +zp_char dw ? ; character to write +zp_attr dw ? ; character's attributes +zp_args ends + + public zputc +zputc proc near + push BP ; save caller's BP + mov BP,SP + pusha + REALIO REAL_PUTC,zp_line,zp_attr,continue + popa + pop BP + ret +zputc endp + +;************************************************************************ +;* Scroll a Window * +;************************************************************************ +zs_args struc + dw ? ; caller's BP + dw ? ; return address +zs_line dw ? ; upper left hand corner line number +zs_col dw ? ; upper left hand corner column number +zs_nline dw ? ; number of lines +zs_ncols dw ? ; number of columns +zs_attr dw ? ; text attributes (used for blanking) +zs_args ends + + public zscroll +zscroll proc near + push BP ; save caller's BP + mov BP,SP + pusha + REALIO REAL_SCROLLUP,zs_line,zs_attr,continue + popa + pop BP + ret +zscroll endp + +;************************************************************************ +;* Scroll Window Down one line * +;************************************************************************ +s_args struc + dw ? ; caller's BP + dw ? ; return address +s_line dw ? ; upper left hand corner line number +s_col dw ? ; upper left hand corner column number +s_nline dw ? ; number of lines +s_ncols dw ? ; number of columns +s_attr dw ? ; text attributes (used for blanking) +s_args ends + + public scroll_d +scroll_d proc near + push BP ; save caller's BP + mov BP,SP + pusha + REALIO REAL_SCROLLDN,s_line,s_attr,continue + popa + pop BP + ret +scroll_d endp + + +;************************************************************************ +;* Emulate cursor in EGA mode * +;* * +;* On Entry: ES:SI points to port object * +;************************************************************************ + public ega_curs +ega_curs proc near + push bp + mov bp,sp + + cmp vid_mode,14 ; are we in in EGA mode? + jl ega_03 ; no, return + + test cur_off,7fh ; cursor already off? (bit one zero) + jz ega_02 ; yes, jump + and cur_off,0feh ; turn off bit one + jmp ega_03 + +ega_02: cmp es:[si].pt_text,0 ; black attribute? + je ega_03 ; forget it + +; set up BIOS call for ega cursor + mov AX,09DBh ; reverse-video block + mov BX,8Fh ; attr = xor,white + mov CX,1 ; repetition count = 1 + int 10h +ega_03: + pop bp + ret +ega_curs endp + +;************************************************************************ +;* Note Changes to Video Mode * +;************************************************************************ +vm_chg struc + dw ? ; caller's BP + dw ? ; return address +vm_chgt dw ? ; new video mode +vm_mode dw ? ; new character height +vm_rows dw ? ; new # rows for screen +vm_chg ends + + public chg_vmode +chg_vmode proc near + push bp + mov bp,sp + REALIO REAL_CHGVMODE,vm_chgt,vm_rows,continue + pop bp + ret +chg_vmode endp + + +;************************************************************************ +;GVCHARS - display characters +; +; Upon Entry: +; cx = number of characters +; dx = wrap flag (0 = don't check for wrap, else check for wrap) +; es:di => print buffer +; +;************************************************************************ + + public gvchars +gvchars proc near + push cx ;character count + push REAL_BUF_PARA ;buffer segment + push di ;buffer offset + push dx ;wrap indicator + push REAL_WRTSTRNG ;op code +; +; Warning: DS does not reference data segment in code below +; + mov cx,pt_bfend ;cx = number bytes to write + mov si,port_ds + LoadPage ds,port_pg ;ds:si => port object +gv_again: + mov ss:local_pds,si ;save port address locally + mov ss:local_ppg,ds + mov di,ss:REAL_BUF_TOP ;get top address of buffer + sub di,cx ;es:di => buffer area + mov ax,BLOCK_XFER ;xfer port object to real memory + int DOS + mov ax,ss ;restore local data segment + mov ds,ax +; stack at this point contains opcode, wrap, buffer offset/seg and length + mov cx,10 ;move 10 bytes + sub di,cx ;es:di => real buffer + mov si,sp ;ds:si => args + mov ax,BLOCK_XFER ;xfer arg data to real memory + int DOS +; issue call to real mode I/O handler + mov al,rpc_handle ;real procedure handle + mov ah,RPC ;rpc function call + push di ;stack pointer + push XLI_REALIO ;real i/o function designator + mov dx,sp ;ds:dx => rpc buffer + mov cx,4 ;cx = # bytes in rpc buffer + mov bx,2 ;bx = number return bytes + int DOS ;issue RPC - I/O request + pop ax ;ax = result status + add sp,2 ;dump other arg from stack + or ax,ax ;test result status + jnz disk_err ;go report error +; update port object + mov cx,pt_bfend ;cx = number bytes to fetch + mov si,REAL_BUF_TOP + sub si,cx + mov bx,es + les di,dword ptr local_pds ;es:di => port object + mov ds,bx ;ds:si => updated port data + mov ax,BLOCK_XFER ;xfer block to scheme heap + int DOS +; everything is written, is there a transcript file? + cmp ss:TRNS_pag,0 ;transcript file associated? + je gvch_ret ; no, return + test es:[di].pt_pflgs,TRANSCRI ;this port have bit set? + jz gvch_ret ; no, return + + mov bx,ds + mov cx,pt_bfend ;cx = number bytes to write + mov es,bx ;es => real buffer + mov si,ss:TRNS_dis + LoadPage ds,ss:TRNS_pag ;ds:si => port object + jmp gv_again ;stack still contains orig argments +; +; Warning: DS does not reference data segment in above code +; +gvch_ret: + mov bx,ss ;restore data segment + mov ds,bx + + add sp,10 ;dump args off stack + xor ax,ax ;return status = 0 + ret ;return to caller + +public disk_err +; ax= dos error, or if negative - disk full +disk_err: + jns der_01 + mov ax,DISK_FULL_ERROR + jmp der_02 +der_01: add ax,(IO_ERRORS_START - 1);make into scheme error +der_02: mov bx,1 ;non-restartable + lea cx,port_r ;port object + pushm ;invoke scheme error handler + call dos_err ;control will not return + +gvchars endp + + +MSDOS equ 021h +TI_CRT equ 049h +IBM_CRT equ 010h +TI_KEYBD equ 04Ah +IBM_KEYB equ 016h + +;************************************************************************ +;* Character at Keyboard ? * +;* * +;* Our equivalent to Lattic C's kbhit function * +;* * +;************************************************************************ + public char_rdy +char_rdy proc near + + mov ah,01h ; load "check keyboard status" function code + + IFNDEF PROMEM ;;;; PROTECTED MODE will ignore + cmp pc_make,TIPC ; TI or IBM flavored PC? + jne zch_IBM + int TI_KEYBD ; issue TI keyboard DSR service call + jz zch_no ; is character buffered? if not, jump + ELSE + jmp zch_IBM + ENDIF +zch_yes: xor AH,AH ; clear high order byte of AX + cmp AL,0 ; test next character to be read + jne zch_ret ; binary zero? if not, jump + mov AX,256 ; if character is 0, make it non-zero +zch_ret: ret ; return (true) + +zch_IBM: int IBM_KEYB ; issue IBM keyboard DSR service call + jnz zch_yes ; is character buffered? if so, jump +zch_no: xor AX,AX ; set result = false + ret ; return (false) +char_rdy endp + +;************************************************************************ +;* Buffered Keyboard Input * +;* * +;* Calling Sequence: ch = getch(); * +;* where ch - the character read from the keyboard * +;************************************************************************ + public getch +getch proc near + push si + push di + mov AH,07h ; function code = Direct Console Input + int MSDOS ; do it + xor AH,AH ; clear the high order byte + pop di + pop si + ret ; return to caller +getch endp + +;************************************************************************ +;* Get Extended Error Information * +;* * +;* Use the Dos function to get extended error information when error * +;* reported on DOS I/O. * +;************************************************************************ +;; public get_io_err +;;get_io_err proc near +;; +;; mov AH,EXT_ERR ; function code = get extended error +;; int MSDOS ; ax will contain error number +;; stc ; set carry flag +;; ret ; return to caller +;;get_io_err endp + +;************************************************************************ +;* Create a File * +;* * +;* Calling sequence: stat = zcreate(handle, pathname) * +;* where: int *handle - location to store handle * +;* returned by open request* +;* char *pathname - zero terminated string * +;* containing the file's * +;* pathname * +;* int stat - the completion code * +;* 0=no errors * +;* 3=path not found * +;* 4=too many open files * +;* 5=access denied * +;************************************************************************ +zop_args struc + dw ? ; caller's BP + dw ? ; return address +zhandle dw ? ; address of handle +zpathnam dw ? ; address of string containing file pathname +zmode dw ? ; mode: 0=read, 1=write, 2=read/write +zhigh dw ? ; address of high word of file size +zlow dw ? ; address of low word of file size +zop_args ends + + public zcreate +zcreate proc near + push BP ; save caller's BP + mov BP,SP + mov AH,03Ch ; load function request id + mov DX,[BP].zpathnam ; load pointer to pathname + mov CX,020h ; create with "archive" attribute + int MSDOS ; issue create request + jc zcr_ret ; if error, jump + mov BX,[BP].zhandle ; load address of handle + mov [BX],AX ; and store returned handle value + xor AX,AX ; set return code for normal return +zcr_ret: pop BP ; restore caller's BP + ret ; return +zcreate endp + +;************************************************************************ +;* Open a File * +;* * +;* Calling sequence: stat = zopen(handle, pathname, access_code) * +;* where: int *handle - location to store handle * +;* returned by open request* +;* char *pathname - zero terminated string * +;* containing the file's * +;* pathname * +;* int access_code - 0=read, 1=write, * +;* 2=read and write * +;* int stat - the completion code * +;* 0=no errors * +;* 2=file not found * +;* 4=too many open files * +;* 5=access denied * +;* 12=invalid access * +;************************************************************************ + + public zopen +zopen proc near + push BP ; save caller's BP + mov BP,SP + mov AH,03Dh ; load function request id + mov AL,byte ptr [BP].zmode ; load access code (mode) + mov DX,[BP].zpathnam ; load pointer to pathname + int MSDOS ; issue open request + jc zop_ret ; if error, jump + mov BX,[BP].zhandle ; load address of handle + mov [BX],AX ; and store returned handle value +; + push AX ; save file handle + mov BX,AX ; set bx to file handle + xor CX,CX + xor DX,DX + mov AX,4202h ; poisition file pointer at eof + int MSDOS + jc zop_ret +; + mov BX,[BP].zhigh ; load address of hsize + mov [BX],DX ; and store returned hsize value + mov BX,[BP].zlow ; load address of lsize + mov [BX],AX ; and store returned lsize value +; + pop BX ; retrieve file handle + xor CX,CX + xor DX,DX + mov AX,4200h ; reset file pointer to begining of file + int MSDOS + jc zop_ret +; + xor AX,AX ; set return code for normal return +zop_ret: pop BP ; restore caller's BP + ret ; return +zopen endp + +;************************************************************************ +;* Close a File * +;* * +;* Calling sequence: stat = zclose(handle) * +;* where: int handle - handle returned by open * +;* request * +;* int stat - the completion code * +;* 0=no errors * +;* 6=invalid handle * +;************************************************************************ + public zclose +zclose proc near + push BP ; save caller's BP + mov BP,SP + mov AH,03Eh ; load function request id + mov BX,[BP].zhandle ; load handle of file to close + int MSDOS ; issue close request + jc zcl_ret ; if error, jump + xor AX,AX ; set return code for normal return +zcl_ret: pop BP ; restore caller's BP + ret ; return +zclose endp + +;************************************************************************ +;* Read From a File * +;* * +;* Calling sequence: stat = zread(handle, buffer, length) * +;* where: int handle - handle returned by open * +;* request * +;* char *buffer - address of character * +;* buffer into which data * +;* is to be read * +;* int *length - on input, the maximum * +;* number of characters * +;* which the buffer will * +;* hold. On output, the * +;* number of characters * +;* actually read. Note: * +;* a return value of zero * +;* characters read * +;* indicates end of file. * +;* int stat - the completion code * +;* 0=no errors * +;* 5=access denied * +;* 6=invalid handle * +;************************************************************************ +zrw_args struc + dw ? ; caller's BP + dw ? ; return address + dw ? ; zhandle (use previous equate) +zbuffer dw ? ; input/output buffer +zlength dw ? ; address of length value +zrw_args ends + + public zread +zread proc near + push BP ; save caller's BP + mov BP,SP + mov AH,03Fh ; load function request id + mov DX,[BP].zbuffer ; load address of input buffer + mov BX,[BP].zlength ; load address of length value + mov CX,[BX] ; then load length for read + mov BX,[BP].zhandle ; load file's handle + int MSDOS ; issue create request + jc zrd_ret ; if error, jump + mov BX,[BP].zlength ; load address of length parameter + mov [BX],AX ; and store number of characters read + xor AX,AX ; set return code for normal return +zrd_ret: pop BP ; restore caller's BP + ret ; return +zread endp + +;************************************************************************ +;* Write to a File * +;* * +;* Calling sequence: stat = zwrite(handle, buffer, length) * +;* where: int handle - handle returned by open * +;* char *buffer - address of character * +;* buffer from which data * +;* is to be written * +;* int *length - on input, the number of * +;* characters to write. * +;* The actual number of * +;* characters which were * +;* written is returned in * +;* "length" * +;* int stat - the completion code * +;* 0=no errors * +;* 5=access denied * +;* 6=invalid handle * +;************************************************************************ + public zwrite +zwrite proc near + push BP ; save caller's BP + mov BP,SP + mov AH,040h ; load function request id + mov DX,[BP].zbuffer ; load address of input buffer + mov BX,[BP].zlength ; load address of length value + mov CX,[BX] ; then load length for write + mov BX,[BP].zhandle ; load file's handle + int MSDOS ; issue write request + jc zwr_ret ; if error, jump + mov BX,[BP].zlength ; load address of length parameter + mov [BX],AX ; and store number of characters written + xor AX,AX ; set return code for normal return +zwr_ret: pop BP ; restore caller's BP + ret ; return +zwrite endp + +;************************************************************************ +;* Read characters from a string * +;* * +;* Calling Sequence: stringrd(page, disp, buffer, &length) * +;* where page,disp: location of string-fed port * +;* buffer and length are as in ZREAD (see above) * +;* * +;* Note: The passing parameter `page' is page # * +;************************************************************************ +strd struc + dw ? ;caller's BP + dw ? ;return address +strdpg dw ? ;Page, displacement of port +strdds dw ? +strdbuf dw ? ;Buffer address +strdlen dw ? ;Length address +strd ends + public stringrd +stringrd proc near + push bp + mov bp,sp + push ds ;save caller's ds + mov ax,es ;save caller's es (making ax nonzero as well) + mov bx,[bp].strdlen ;cx = number of chars to transfer + mov cx,[bx] + mov di,[bp].strdpg ;get port page + mov dx,di ; and save for later + LoadPage ds,di + mov di,[bp].strdds ;ds:di => port object + mov si,word ptr[di+car].pt_ptr ;point DS:SI to string + mov bl,[di+car_page].pt_ptr + xor bh,bh + LoadPage ds,bx + cmp byte ptr[si],STRTYPE ;is this a string? + jne nostr ; no, jump (error) + mov bx,[si].str_len ;fetch string length + cmp bX,0 ;check for small string + jge strn_01 + add bx,BLK_OVHD+PTRSIZE +strn_01: LoadPage es,dx ;restore ptr to port + mov dx,es:[di].pt_ullin ;fetch position within string + sub bx,dx ;bx = #chars left + jns notpast ;if not negative, skip + xor bx,bx ; else #chars = 0 +notpast: cmp bx,cx + jae max ;set CX to # of chars left or max + mov cx,bx ;called for, whichever is smaller +max: add si,dx ;adjust si into string + add dx,cx ;reset pointer into string + mov es:[di].pt_ullin,dx + mov es,ax ;restore for C + mov di,[bp].strdbuf ;point di to buffer + xor ax,ax ;prepare to return 0 (all's well) + jmp short storlen ;store # of chars +nostr: xor cx,cx ;when not a string, move no chars +storlen: mov bx,[bp].strdlen ;set length to # of chars read + mov es:[bx],cx + rep movsb ;transfer bytes + pop ds ;restore caller's ds + pop bp + ret +stringrd endp + +;******************************************************************** +;Set File Position * +; * +; set_pos will set the file position, determing which chunk * +; of the file to read and then setting the file position to * +; the appropriate place. A chunk is a multiple of 256 bytes. * +; * +;******************************************************************** +set_arg struc + dw ? ;callers bp + dw ? ;callers es + dw ? ;return addres +set_prt dw ? ;port +set_amt dw ? ;chunk +set_buf dw ? ;position within chunk +set_arg ends + + public set_pos +set_pos proc near + push es + push bp + mov bp,sp ;set up stack + + mov ax,1 + pushm + C_call get_port,,Load_ES ;get port object + mov sp,bp ;dump args + test ax,ax ;check return status + jz set_010 ;jump if we have a port +setferr: + lea bx,sfp_err ;address of error message + pushm <[bp].set_buf, [bp].set_amt, [bp].set_prt> + mov ax,3 + pushm + C_call set_src_,,Load_ES ;set_src_err + mov sp,bp + mov ax,-1 + jmp set_don +set_010: + mov bx,tmp_page + LoadPage es,bx ;get page address of port + mov si,tmp_disp + test es:[si].pt_pflgs,WINDOW ;window port? + jnz setferr +;we have a file + mov di,[bp].set_amt + mov dx,[di] ;dx = chunk number + inc dx + mov word ptr es:[si].pt_chunk,dx ;update chunk # in port + dec dx + mov cl,8 ;make chunk number into # bytes + xor bx,bx + mov bl,dh + xor dh,dh + shl dx,cl ;multiply dx by 256 + mov cx,bx ;cx:dx = # bytes (32bit int) + + test byte ptr es:[si].pt_pflgs,READWRITE+WRITE_ONLY ;test port flags + pushf ;save flags for later + jz set_015 ;if input port, jump + or byte ptr es:[si].pt_pflgs,DIRTY ;else set dirty bit + mov bx,[bp].set_buf ; get chunk offset + add dx,[bx] ; and add to file position +set_015: ;cx:dx = distance to move (bytes) + mov bx,es:[si].pt_handl ;bx = file handle + mov ah,42h ;move file pointer + mov al,0 ;position from file start + int MSDOS ;move it + popf ;restore flags + jnz set_020 ;jump if output port + + mov cx,256 ;cx = length of buffer + mov bx,es:[si].pt_handl ;bx = file handle + mov dx,si + add dx,pt_buffr ;dx = start of buffer + push ds + push es + pop ds ;ds:dx => buffer + mov ah,3fh ;read from a file + int MSDOS + pop ds ;restore ds + jc set_don ;return on error + mov es:[si].pt_bfend,ax ;update number of bytes read +set_020: + mov bx,[bp].set_buf + mov ax,[bx] + mov es:[si].pt_bfpos,ax ;update buffer position +set_don: + pop bp + pop es + ret +set_pos endp + +;******************************************************************** +;SGRAPH * +; Interface to Graphic Primitives (%graphics arg1 ... arg7) * +; * +;******************************************************************** + public sgraph +BUFFER_IS_STACK ; denote emulate stack with real buffer +sgraph: mov CX,7 ; load counter-- seven arguments + xor DX,DX ; set error flag = FALSE + lods byte ptr ES:[SI] ; load first argument + save ; and save as destination register + GET_REAL_BUFFER_STACK ; es:di => top of buffer + jmp short sgraph0 +; loop thru args, moving to real mode buffer +sgraph1: lods byte ptr ES:[SI] ; load next argument +sgraph0: xor AH,AH ; be sure high byte is zero + mov BX,AX ; copy register number to BX + cmp byte ptr reg0_pag+[BX],SPECFIX*2 ; is arg a fixnum? + je sgraph2 ; if arg *is* a fixnum, o.k. (jump) + inc DX ; indicate an invalid argument +sgraph2: mov AX,reg0_dis+[BX] ; expand 15-bit signed int to 16-bit signed int + shl AX,1 + sar AX,1 + push ES + push SI + push CX ; save around following + MOVE_ARGS_TO_BUF ,REAL_MODE_BUFFER,autodecr,save + pop CX ; restore count + pop SI + pop ES + loop sgraph1 ; continue 'til all arguments processed +; all args moved to buffer + cmp DX,0 ; any argument errors? + je sg_005 + jmp sgraph3 ; if errors encountered, jump +sg_005: + save ; save the location pointer + mov BX,[BP].save_AX ; restore first argument register (op-code) +; use graphics op-code as index into graphics-go table to indicate whether +; return values are expected; on hboard parallel processing can exist. + mov BX,reg0_dis+[BX] ; get value + shl BX,1 ; expand to 16 bit signed integer + sar BX,1 + mov bl,[graphic_go+bx] ; index into return value table + push bx ; save # return values for later + or bl,bl ; does it return a value? + jz sg_010 ; no, jump + mov bx,2 ; bx = # bytes to return +; build rpc buffer on the local stack and issue the rpc call +sg_010: + GET_REAL_BUFFER ; es:di => next loc in stack buffer + add di,2 ; make last loc top of stack + push di ; pass stack ptr + mov cx,4 ; cx = # bytes to pass + push XLI_GRAPH ; Type code - %graphics + mov dx,sp ; ds:dx => transaction buffer + mov al,rpc_handle + mov ah,RPC ;Issue RPC + int DOS + xor ax,ax ;default return result to zero + pop bx ;bx = return result + pop cx ;adjust stack +; if return value not expected exit back to interpreter loop, otherwise +; if set-video-mode op code get additional return values from transaction +; buffer + pop cx ;if no result expected + jcxz sg_030 ; then return + mov ax,bx ;ax = return result + or ax,ax ;If negative result + jl sg_030 ; then some kind of error + cmp cx,1 ;Additional values expected? + je sg_030 ; no, jump + ; yes, must be set-video-mode + push ax ; save return result around call + add di,8 ; address buffer for 3 return + MOVE_ARGS_FROM_BUF + mov MAX_ROWS,AL + push AX + push vid_mode + push char_hgt + call chg_vmode ; tell real mode i/o code about changes + add sp,6 ; dump args off stack + +; +;The following must be done so that OS/386 recognizes mode change has been made. +; + cmp pc_make,1 ;tipc? + je sg_028 ; yes, jump + mov ax,VID_MODE + xor ah,ah + int 10h + +sg_028: + pop ax ; restore return result +; at this point, ax contains the return result +sg_030: + shl AX,1 ; clear high order bit of result + shr AX,1 ; (convert to immediate value) + mov BX,[BP].save_AX ; restore destination register number + mov reg0_dis+[BX],AX ; store returned result into destination reg +not_pc: jmp next_SP ; return to interpreter +sgraph3: mov BX,offset m_graph ; load addr of "%graphics" text + jmp src_err ; link to Scheme debugger +BUFFER_IS_BUFFER ;subsequent uses of buffer as buffer + +;*************************************************************************** +;* Link for routines in PROGX * +;*************************************************************************** + extrn shft_brk:near + extrn dos_err:near + public shft%brk + public dos%err +shft%brk proc far + call shft_brk ;link to SHF BREAK process + ret +shft%brk endp + +dos%err proc far + call dos_err ;link to DOS fatal error process + ret +dos%err endp + +prog ends + + +XGROUP group PROGX +PROGX segment byte public 'PROGX' + assume CS:XGROUP + +;************************************************************************ +;* Perform appropriate VIDEO I/O interrupt * +;* Any difference in register definition should be handled by * +;* the caller except where DH,DL contain row,col information. * +;************************************************************************ + public crt_dsr +crt_dsr proc far + cmp PC_MAKE,TIPC + jne ibm_dsr + + IFDEF PROMEM ;;; PROTECTED MODE + mov pro_msb,ax ;Save Machine State Block + mov pro_msb+2,bx + mov pro_msb+4,cx + mov pro_msb+6,dx + + lea dx,pro_msb ;;; Do real mode interrupt + xor bx,bx + cmp ah,3 ;;; Read Cursor position + je crt_d02 + cmp ah,8 ;;; Read Char and Attribute + jne crt_d04 +crt_d02: mov bx,8 ;;; Wait for return value +crt_d04: + mov ax,0E349h + int 21h + + mov ax,pro_msb ;;; restore ax + mov bx,pro_msb+2 ;;; restore bx + mov cx,pro_msb+4 ;;; restore cx + ret + + ELSE + int TI_CRT + ret + ENDIF +ibm_dsr: xchg DH,DL ; Do this now instead of making special checks + int IBM_CRT ; IBM's row,col is diff'rnt from TI's col,row + ret +crt_dsr endp + +PROGX ends + end + \ No newline at end of file diff --git a/proiosup.asm b/proiosup.asm new file mode 100644 index 0000000..b21d215 --- /dev/null +++ b/proiosup.asm @@ -0,0 +1,343 @@ +; =====> PROIOSUP.ASM +;*************************************** +;* TIPC Scheme '84 Runtime Support * +;* I/O Utilities * +;* * +;* (C) Copyright 1984,1985 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: June 1984 * +;* Last Modification: 09 July 1985 * +;*************************************** + include scheme.equ + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP + public port_r, port_pg, port_ds, port_seg + +;Current port data +port_r equ $ +port_ds dw 0 +port_pg dw 0 ; port_reg +port_seg dw 0 ; port segment address + +;error messages +bad_set db "[VM INTERNAL ERROR] setadr: bad port",CR,LF,0 + +data ends + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP + +;For space and performance reasons, some procedures have been written in the +; following style: the arguments are popped off the stack, and the +; procedure ends in an indirect JMP instead of a RET. In this source file, +; the following are such procedures: +; isspace, copybig + +; Set Port Address +; Calling sequence: ssetadr(page,disp) +; Where ---- page: page number +; disp: displacement within page of port object +set_arg struc + dw ? ; caller's BP + dw ? ; return address +pg dw ? ; adjusted page number +dis dw ? +set_arg ends + public ssetadr +ssetadr proc near + push bp + mov bp,sp + mov bx,[bp].pg ; adjusted page number + cmp byte ptr ptype+[bx],PORTTYPE*2 ; check port type + je sset_info ; jump if port +; Display error message + lea si,bad_set ; address of error message + push si + C_call printf,,Load_ES ; print error message + mov sp,bp + C_call force_de ; force_debug + mov sp,bp + mov ax,1 ; return error status + jmp sset_ret +; get port information +sset_info: + mov port_pg,bx + mov bx,[bp].dis + mov port_ds,bx + xor ax,ax ; return status +sset_ret: + pop bp + ret +ssetadr endp + +; Save stack pointer in case of abort +; Calling sequence: setabort() +; NOTE: Due to the program-sensitive nature of this routine, a call to +; SETABORT MUST be the very first in a C routine, and there must be +; NO preassigned local variables. + public setabort +setabort proc near + mov BX,SP ;Fetch stack pointer + mov SI,SS:[BX] ;Fetch return address + mov CL,CS:[SI-6] ;Fetch byte just before MOV BP,SP + cmp CL,55h ;Compare with PUSH BP opcode + je nolocal ;Jump if no extra stack space allocated + xor CH,CH ;Clear CH + add BX,CX ;Discount extra stack space +nolocal: add BX,2 ;Discount SETABORT's return address + mov DGROUP:abadr,BX ;Save pointer + ret +setabort endp + + +; Abort & set stack to saved pointer +; Calling sequence: abort(code) +; where: code ---- type of error message to print + public abort +abort proc + pop AX ;Discard return address (leaving CODE) + C_call errmsg ;Print error message + pop AX ;Get "value" + mov SP,DGROUP:abadr ;Restore stack for abort + pop BP ;Restore BP + ret ;Return (from aborted operation) +abort endp + + +; Find approximate space left on stack +; Caling sequence: stkspc() + extrn _base:word + public stkspc +stkspc proc near + mov AX,SP + sub AX,DGROUP:_base + ret +stkspc endp + +; Parse input integer +; Calling sequence: buildint(work,buf,base) +; Where ---- work: pointer to some workspace +; buf: pointer to integer characters +; base: numeric base +int_args struc + dw ? ;Caller's BP + dw ? ;Return address +bigptr dw ? ;Pointer to workspace +atptr dw ? ;Pointer to integer characters +bas dw ? ;Numeric base +int_args ends + public buildint +buildint proc near + push BP + mov BP,SP + cld ;Direction forward + mov SI,[BP].atptr ;Point DS:SI to characters + lodsb ;Fetch first character + cmp AL,'-' ;Negative? + pushf ;Save ZF + je negint ;Jump if negative + cmp AL,'+' ; or if signed positive + je negint + dec SI ;Point SI back to first char +negint: mov CX,1 ;At first, bignum is one word + add word ptr[BP].bigptr,3 ;Point BIGPTR to bignum proper +skiplp: lodsb ;Get first number char + cmp AL,'#' ;We know the base - skip all #x's + jne skipped ;All #x's skipped - parse number + inc SI ;Otherwise check again + jmp skiplp +biglp: lodsb ;Get next int character +skipped: mov DI,[BP].bigptr ;Point ES:DI to workspace + sub AL,'0' ;Character -> number + js bigend ;Jump if number ended + cmp AL,9 ;Jump if ordinary digit + jbe orddig + and AL,7 ;Otherwise, parse extra hex digit + add AL,9 +orddig: xor AH,AH ;Clear AH + call bigx10 ;Multiply bignum by 10, adding digit + jmp biglp +bigend: sub DI,3 ;Point DI back to start of buffer + mov AX,CX ;Save integer size + stosw + xor AL,AL ;Clear AX + popf ;Get number's sign + jne stosgn ;Store it + inc AL +stosgn: mov [DI],AL + pop BP ;Restore BP + ret +;BIGX10: Multiply bignum at ES:[DI], size=CX words, by BASE and add AX +bigx10: push CX + mov DX,AX ;Transfer digit to add + cld +x10lp: mov AX,[DI] ;Get word to multiply + call wordx10 ;Multiply word by 10 + stosw ;Replace result + loop x10lp ;Loop 'til done + pop CX ;Restore CX + or DX,DX ;Does a carry remain? + jz samlen ;Jump if not + mov ES:[DI],DX ;Otherwise, enlarge bignum + inc CX +samlen: ret +;WORDX10: Multiply AX by BASE and add DX; product in AX, carry in DX +wordx10: push CX ;Save value of CX + push DX ;Save carry in + mul word ptr[BP].bas ;Multiply by BASE + pop CX ;Restore carry to CX + add AX,CX ;Add carry + adc DX,0 + pop CX ;Restore CX + ret +buildint endp + +; Copy bignum data to a math buffer +; Calling sequence: copybig(pg,ds,buf) +; Where: pg,ds ---- page & displacement of bignum +; buf ------ pointer to math buffer +cb_args struc + dw ? ;Caller's BP + dw ? ;Return address +cbpg dw ? ;Page +cbds dw ? ;Displacement +cbbuf dw ? ;Buffer pointer +cb_args ends + public copybig +copybig proc near + pop BX ;Pop return address to BX + mov DX,DS ;Save DS in DX + pop SI ;Fetch logical page number + sal SI,1 ;Convert + LoadPage DS,SI ;Get page segment +;;; mov DS,DGROUP:pagetabl+[SI] ;Get page segment + pop SI ;Get displacement + mov AX,[SI]+1 ;Get size of bignum proper (words) + sub AX,4 + shr AX,1 + add SI,3 ;Point DS:SI to sign byte + pop DI ;Point ES:DI to math buffer + cld ;Direction forward + stosw ;Store bignum size in math buffer + movsb ;Copy sign byte + mov CX,AX ;Copy bignum proper + rep movsw + mov DS,DX ;Restore DS + jmp BX ;Return +copybig endp + +; Convert buffered bignum to ASCII +; Calling sequence: big2asc(mathbuf,charbuf) +; Where: mathbuf --- pointer to buffered bignum +; charbuf --- pointer to ASCII charcater array +b2a struc + dw ? ;Caller's BP + dw ? ;Return address +mbuf dw ? ;Math buffer +cbuf dw ? ;Character buffer +b2a ends + public big2asc +big2asc proc near + push BP + mov BP,SP + mov SI,[BP].mbuf ;Fetch math buffer pointer + mov DI,[BP].cbuf ;Fetch character buffer pointer + cld ;Direction forward + lodsw ;Fetch bignum size + mov CX,AX + lodsb ;Fetch sign + test AL,1 ;Skip on positive bignum + jz posbig + mov AL,'-' ;First character: minus + stosb +posbig: mov BX,10 ;Set divisor to 10 + and AX,1 ;Push 0 or 1 (1 if start with -) +prtbglp: push AX + call divbig ;Divide bignum by 10 + mov AL,DL ;Store digit + add AL,'0' + stosb + pop AX ;Increment character counter + inc AX + or CX,CX ;Loop until bignum is zeroed + jnz prtbglp + mov CX,AX ;Transfer & save character count + push AX + sub DI,CX ;Point DI to beginning of string + call reverse ;Reverse digits in ASCII bignum + pop AX ;Restore character count + pop BP + ret +;Divide bignum at DS:SI, length CX words, by BX (ES=DS) +divbig: push CX ;Save count + push DI ;Save DI + add SI,CX ;Point SI to last word (most signif.) + add SI,CX + sub SI,2 + cmp [SI],BX ;Will working length be reduced? + pushf + mov DI,SI ;ES:DI = DS:SI + std ;Direction backward + xor DX,DX ;Clear carry in +divlp: lodsw ;Fetch piece of dividend + div BX + stosw ;Store quotient (retain remainder) + loop divlp + add SI,2 ;Point SI again to first word + popf + pop DI + pop CX + jae divdone ;Jump if bignum length not reduced + dec CX +divdone: ret ;Remainder left in DX +;Reverse the string containing CX characters at ES:DI (ES=DS) +reverse: cmp byte ptr[DI],'-' ;Start with minus? + jne revpos ;No, reverse whole string + inc DI ;Otherwise, don't include minus in reverse + dec CX +revpos: mov SI,DI ;Point SI to last string char + add SI,CX + dec SI + shr CX,1 ;Number of switches + or CX,CX ;Jump if no switches to make + jz revend +revlp: mov AL,[DI] ;Exchange outside bytes + xchg AL,[SI] + stosb + dec SI ;Move pointers inward + loop revlp +revend: ret +big2asc endp + +; Is character a whitespace? +; Calling sequence: isspace(ch) +; Where ch = character to check +; Returns zero iff not a whitespace +; NOTE: Before use, the C macro ISSPACE must not be defined +isspargs struc + dw ? ;Return address +issparg dw ? ;Argument +isspargs ends + public isspace +isspace proc near + pop DI ;Get return address + pop AX ;Get argument + cmp AL,' ' + je issp + cmp AL,9 + jb isntsp + cmp AL,13 + jbe issp +isntsp: xor AX,AX ;Set to zero +issp: jmp DI ;Return +isspace endp + +prog ends + end + + \ No newline at end of file diff --git a/proread.asm b/proread.asm new file mode 100644 index 0000000..308e209 --- /dev/null +++ b/proread.asm @@ -0,0 +1,821 @@ +; =====> PROREAD.ASM +;***************************************************************** +;* Lowlevel Read Support * +;* * +;* (C) Copyright 1985, 1986 by Texas * +;* Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Date Written: 24 March 1986 * +;* Last Modification: * +;* * +;* 14 Apr 86 (tc) Change references to pagetabl to call * +;* memory manager for use with ext/exp memory. * +;* 9 Sep 86 (ds) EGA support. * +;* 21 Nov 86 (rb) Detect disk full error correctly. * +;* 7 Jan 87 (ds) Added support for random I/O. * +;* 10 Feb 87 (tc) EOF-DISP modified to reflect other changes. * +;* in Page 5 symbols. * +;* 16 Mar 87 (tc) Added Binary I/O, Error handling, better * +;* handling for Disk Full * +;***************************************************************** + page 60,132 + include scheme.equ + include sinterp.arg + +MSDOS equ 21h + +BACKSP equ 08 +TAB equ 09 +RETURN equ 0Dh +LF equ 0Ah +CTRL_Z equ 1Ah +LEFT_AR equ 4Bh +RIGHT_AR equ 4Dh +F3 equ 3Dh +F5 equ 3Fh +INSERT equ 52h +DELETE equ 53h +ENTER equ 0Dh +NULL_CH equ 0 +BELL_CH equ 07 +BLANK equ 0020h + +SCREEN_WIDTH equ 80 +buf_len equ 253 + +DGROUP group data +data segment word public 'DATA' + assume DS:DGROUP +;from iosuport.asm + extrn port_r:word, port_pg:word, port_ds:word, port_seg:word +;from ??? + extrn vid_mode:word + + + public cur_off, char_hgt +; +; Local error messages +; +ch_rd db "CHAR-READY?",0 +rch_er db "READ-CHAR",0 +push_er db "[VM INTERNAL ERROR] pushchar: failed",CR,LF,0 +rd_st_er db "[VM INTERNAL ERROR] takechar: source not a string",CR,LF,0 + + +cur_off dw 0 +char_hgt dw 8 + +; +; The following data is used to capture and restore data entered from +; the console. All characters entered are saved in a shadow buffer +; so that they may be recalled via the F3, and F5 keys +; +insert_m dw 0 ;insert mode flag +index dw 0 ;index into port buffer +sh_ptr dw 0 ;pointer into shadow buffer +sh_len dw 0 ;length of shadow buffer +sh_bufer db 256 dup (0) ;shadow buffer for characters +row dw 256 dup (0) ;row vector +column dw 256 dup (0) ;column vector + +data ends + + +PGROUP group prog +prog segment byte public 'PROG' + assume CS:PGROUP +;from basicio.asm + extrn zbell:near,zscroll:near,zputcur:near + extrn zputc:near,zcuron:near,zcuroff:near + extrn zread:near,stringrd:near,char_rdy:near + extrn ega_curs:near +;from ??? + extrn getch:near,ssetadr:near +;from + extrn toblock:near +;from sprint.asm + extrn printtxt:near +;from sinterp.asm + extrn next_SP:near,src_err:near,sch_err:near,dos_err:near + +;;;************************************************************************** +;;; Input a Single Character +;;;************************************************************************** + +take_buf_len equ 256 + +take_arg struc +tk_leng dw take_buf_len +new_bpos dw 0 +tk_bp dw ? ;caller's BP + dw ? ;caller's ES + dw ? ;caller's return address +take_arg ends + + public take_ch +take_ch proc near + push es + push bp + sub sp,offset tk_bp ;allocate local storage + mov bp,sp + mov [BP].new_bpos,0 ;buf position after refilling buf + LoadPage es,port_pg + mov si,port_ds ;es:si => port object + +; Fix for random I/O - read preceeded by a write + test byte ptr es:[si].pt_pflgs,READWRITE+WRITE_ONLY + jz take_c00 ;skip if input port + mov bl,byte ptr es:[si].pt_pflgs ;get port flags + and bl,DIRTY+STRIO+OPEN+WINDOW ;isolate appropriate flags + cmp bl,DIRTY+OPEN ;buffer modified? + jne take_c00 ; no, jump + and byte ptr es:[si].pt_pflgs,NOT DIRTY ;clear flag +; this read was preceeded by at least one write, so reposition file pointer +; so it rereads the buffer + mov bx,word ptr es:[si].pt_handl + dec word ptr es:[si].pt_chunk + mov cx,word ptr es:[si].pt_chunk + xor dl,dl + mov dh,cl + mov cl,ch + xor ch,ch + mov ax,4200h ; reposition file pointer + int MSDOS + mov bx,es:[si].pt_bfpos ; after re-reading file, restore + mov [BP].new_bpos,bx ; current buffer position + jmp take_fill ; go re-read the file +take_c00: + mov bx,es:[si].pt_bfpos + cmp bx,es:[si].pt_bfend ;have we exceeded port's buffer? + jge take_fill ; yes, go fill it again +take_nxt: + xor ah,ah + mov al,byte ptr es:[si+pt_buffr+bx] ;get next char from buffer + inc bx ;bump buffer position pointer + mov es:[si].pt_bfpos,bx ; and update in port object + cmp al,CTRL_Z ;control-z? + jne take_ret ; no, return + test es:[si].pt_pflgs,BINARY ;binary file? + jnz take_ret ; no, return +take_eof: mov AX,256 ;text file, send EOF +take_ret: add sp,offset tk_bp ; release local storage + pop bp + pop es + ret + +; buffer empty -- fill it up +take_fill: + mov [BP].tk_leng,take_buf_len ;set up buffer length + test es:[si].pt_pflgs,WINDOW ;window port? + jz take_fil ; no, jump + test es:[si].pt_pflgs,STRIO ;string port? + jnz take_str ; yes, jump +; read from window + call read_win ;read from window + mov BX,AX + jmp take_11 +; Read from file + public take_fil +take_fil: + cmp word ptr es:[si].pt_chunk,1 ; operating on first chunk? + jne take_f05 ; no, jump + cmp word ptr es:[si].pt_bfpos,0 ; Have we filled the buffer yet? + je take_f10 ; yes, jump +take_f05: + inc word ptr es:[si].pt_chunk ; bump the chunk number +take_f10: + push bp ; + lea ax,row + push ax ;address of input buffer + push es:[si].pt_handl ;file handle + call zread ;read from file + mov sp,bp ;dump args from stack + test ax,ax ;error? + jnz take_err ; yes, jump + jmp take_10 +; read character from string +take_str: + mov ax,ds + mov es,ax ;es = ds + push bp ; + lea bx,row + push bx ;buffer for characters + push port_ds ;port displacement + push port_pg ;port page + call stringrd ;read from string + mov sp,bp ;dump args off stack + test ax,ax ;error encountered? + jz take_05 ; no, jump + lea bx,rd_st_er ;address of error message + push bx + C_call printf ;display error message + mov sp,bp ;dump args from stack +take_05: + LoadPage es,port_pg ;restore port addressability + mov si,port_ds +; +take_10: mov bx,[bp].tk_leng ;bx = length +take_11: mov es:[si].pt_bfend,bx ;update buffer length + test bx,bx ;length = zero? + jnz take_20 ; no, jump + mov es:[si].pt_bfpos,bx ; yes, position = end + jmp take_eof ; note eof +take_20: + test es:[si].pt_pflgs,WINDOW ;window port? + jz take_22 ; no, jump + test es:[si].pt_pflgs,STRIO ;string port? + jz take_25 ; no, jump +; copy characters from buffer to file object +take_22: + push si ;tempsave si + mov di,si + add di,pt_buffr ;es:di => port buffer + lea si,row ;ds:si => char buffer + mov cx,bx ;# characters to move + cld ;direction forward +rep movsb ;do it + pop si ;restore si +take_25: + mov bx,[bp].new_bpos ;BX = buffer position + jmp take_nxt +take_err: +; We will not return from call to dos_err + add ax,(IO_ERRORS_START - 1) ;make Dos I/O error number + mov bx,1 ;non-restartable + lea cx,port_r ;port object + pushm ;invoke scheme error handler + call dos_err ;control will not return here +take_ch endp + +;************************************************************************** +; Read a "record" from window +; ES:SI points to the window object +; Return AX = number of characters read +;************************************************************************** +read_arg struc + dw ? ;caller's bp + dw ? ;return address +read_arg ends + + public read_win +read_win proc near + push bp + mov bp,sp + mov index,0 ;clear index into port buffer + mov sh_ptr,0 ;clear index into shadow buffer + mov insert_m,0 ;clear insert flag + call zcuron ;turn on the cursor + mov bx,es:[si].pt_text ;get text attribute for window +read_001: + mov bx,es:[si].pt_cline ;bx = current line number + cmp bx,es:[si].pt_nline ;have we exceeded number of lines? + jl read_put ; no, jump + push es:[si].pt_text + push es:[si].pt_ncols + push es:[si].pt_nline + push es:[si].pt_ulcol + push es:[si].pt_ullin + call zscroll ;scroll up one line + mov sp,bp ;dump args off stack + mov bx,es:[si].pt_nline + dec bx + mov es:[si].pt_cline,bx ;current line = #lines - 1 + mov es:[si].pt_ccol,0 ;current column = 0 +read_put: + mov dx,es:[si].pt_ccol + add dx,es:[si].pt_ulcol + add bx,es:[si].pt_ullin + pushm + call zputcur ;show the cursor + mov sp,bp ;bump args off stack + + call getch ;get character from console + test al,al ;extended character? + jz read_ex + jmp read_100 ; no, go process ascii character +; +; Process extended key sequence +; +read_ex: + call getch ;get extended character from console + cmp al,LEFT_AR ;left arrow key? + jne read_ra ; no, jump + jmp read_bs ; yes, treat as backspace +; Check for RIGHT ARROW key +read_ra: + cmp al,RIGHT_AR ;right arrow key? + jne read_f3 ; no, jump + mov insert_m,0 ;turn off insert mode + mov bx,sh_ptr ;bx => shadow buffer + cmp bx,sh_len ;if more chars in shadow buffer + jl read_030 ; then go fetch + jmp read_001 ; else go read next char from window +read_030: + lea di,sh_bufer ;ds:di => shadow buffer + mov al,byte ptr [di+bx] ;fetch character from buffer + jmp read_one ;and go echo to screen +; Check for F3 key +read_f3: + cmp AL,F3 ;F3 key? + jne read_f5 ; no, jump + mov insert_m,0 ;turn off insert mode +read_041: mov cx,index + cmp cx,buf_len ;have we exceeded port buffer? + jl read_043 ; no, jump + jmp read_001 ;no room for more chars +read_043: + mov bx,sh_ptr ;bx => shadow buffer + cmp bx,sh_len ;have we exceeded length of buffer? + jl read_045 ; no, jump + jmp read_001 +read_045: lea di,sh_bufer ;ds:di => shadow buffer + mov al,byte ptr [di+bx] ;get character from buffer + call echo_ch ;echo to screen + mov sp,bp ;bump args from stack + jmp read_041 ;go get next character +; Check for F5 key +read_f5: cmp AL,F5 ;F5 key? + jne read_ins ; no, jump + call ega_curs ;turn off the EGA cursor + mov insert_m,0 ;disable insert mode + cmp index,0 + jne read_051 + jmp read_001 +read_051: + call str_str ;copy from port buf to shadow buf + mov bx,index ;bx = index into port buffer + mov sh_len,bx ;update shadow buffer length + mov byte ptr [di+bx],0 ;note end of string + dec bx ;bx => last char in shadow buffer + lea di,row ;di => row vector +read_053: + cmp bx,0 ;reached start of shadow buffer? + jl read_055 ; yes, exit loop + cmp byte ptr [di+bx],0 ;at top of screen? + jl read_055 ; yes, exit loop + mov ax,BLANK ;blank character for write + lea si,column ;si => column vector + xor ch,ch + mov cl,byte ptr [si+bx] ;cl = column for character + xor dh,dh + mov dl,byte ptr [di+bx] ;dl = row for character + mov si,port_ds ;si => port object + mov es:[si].pt_ccol,cx ;update column + mov es:[si].pt_cline,dx ; and row + add cx,es:[si].pt_ulcol ;cx = column within window + add dx,es:[si].pt_ullin ;dx = row within window + push bx ;tempsave bx around call + + push es:[si].pt_text ;text attribute + push ax ;blank character + push cx ;column + push dx ;row + call zputc ;clear character from window + add sp,8 ;dump args off stack + + pop bx ;restore shadow buffer index + dec bx ;and decrement for next character + jmp read_053 ;go clear next character +read_055: + mov index,0 ;clear index into port buffer + mov sh_ptr,0 ;clear index into shadow buffer + jmp read_001 ;go read the next character +; Check for INSERT key +read_ins: cmp al,INSERT ;insert key? + jne read_del + call ega_curs ;turn off the EGA cursor + mov insert_m,1 ;turn on insert mode + jmp read_001 +; Check for DELETE key +read_del: cmp al,DELETE ;delete key? + jne read_EN + mov insert_m,0 ;turn off insert mode + mov bx,sh_ptr + cmp bx,sh_len ;ensure still within shadow buffer + jg read_d02 +read_d01: inc sh_ptr +read_d02: jmp read_001 +; Check for ENTER key +read_EN: cmp al,ENTER ;enter key? + je read_RT ; yes, treat as carriage return + jmp read_001 ;ignore all other extended keys +; +; Process ascii character key +; + +; Check for BACKSPACE key +read_100: + cmp al,BACKSP ;backspace? + jne read_200 ; no, try next +read_bs: mov insert_m,0 ;disable insert mode + call ega_curs ;disable EGA cursor + mov bx,index ;bx = port buffer index + cmp bx,0 ;if already at buffer start + jle read_150 ; then jump + dec bx ;decrement port buffer index + lea di,row ;ds:di => row vector + cmp byte ptr [di+bx],0 ;if at screen start + jl read_150 ; then jump + mov index,bx ;save buffer index + cmp sh_ptr,0 ;if at start of shadow buffer + je read_120 ; then jump + dec sh_ptr ; else backspace one character +read_120: lea di,column ;ds:di => column vector + xor ch,ch + mov cl,byte ptr [di+bx] ;get column of prior character + mov es:[si].pt_ccol,cx ; and update within port object + add cx,es:[si].pt_ulcol ;cx = col within window + xor dh,dh + lea di,row + mov dl,byte ptr [di+bx] ;get line of prior character + mov es:[si].pt_cline,dx ; and update within port object + add dx,es:[si].pt_ullin ;dx = line within window + + mov bx,BLANK + push es:[si].pt_text ;text attribute + push bx ;blank character + push cx ;column + push dx ;line + call zputc ;blank out char on screen + mov sp,bp ;dump args off stack + jmp read_001 +read_150: + call zbell ;beep + jmp read_001 +; Check for BACKSPACE key +read_200: cmp al,RETURN ;carriage return? + je read_RT ; yes + jmp read_300 ; no, jump +; Process return key +read_RT: + cmp vid_mode,14 ;if not in ega mode + jl read_rt1 ; then jump + call ega_curs ; else turn off the ega cursor + or cur_off,1 ; and note cursor off +read_rt1: + mov bx,index ;bx = port buffer index + mov byte ptr es:[si+pt_buffr+bx],RETURN ;move CR to buffer + inc bx + mov byte ptr es:[si+pt_buffr+BX],LF ;move LF to buffer + inc bx + mov index,bx ;update port buffer pointer + mov es:[si].pt_ccol,0 ;clear current column + mov dx,es:[si].pt_cline ;get current line + inc dx ; and increment + cmp dx,es:[si].pt_nline ;if still on screen + jl read_220 ; then jump + push es:[si].pt_text + push es:[si].pt_ncols + push es:[si].pt_nline + push es:[si].pt_ulcol + push es:[si].pt_ullin + call zscroll ;scroll up one line + mov sp,bp ;dump args off stack + mov dx,es:[si].pt_nline + dec dx +read_220: mov es:[si].pt_cline,dx ;update current line + call str_str ;copy shadow buffer into port buffer + cmp TRNS_pag,0 + je read_250 + test es:[si].pt_pflgs,TRANSCRI + jz read_250 +; transcript file "on", write buffer to transcript file + push si ;save current port disp + push port_pg ;save current port page number + + pushm + call ssetadr ;set transcript file address + add sp,4 ;bump args off stack + mov ax,index + dec ax + push ax ;index into buffer + lea bx,sh_bufer + push bx ;buffer address + call printtxt ;output to transcript file + add sp,4 ;dump args off stack + ;use port args saved above + call ssetadr ;restore current port address + pop bx ;restore port page number + LoadPage es,bx ;es:si => port object + pop si ;restore port displacement + lea di,sh_bufer ;ds:di => shadow buffer +read_250: + mov bx,index ;bx = index into port buffer + dec bx ;decrement + mov byte ptr [di+bx],0 ;note end of string in shadow buffer + dec bx + mov sh_len,bx ;update shadow length + jmp read_done +; Check for LINEFEED key +read_300: + cmp al,LF ;line feed? + jne read_one ; no, jump + jmp read_001 ; yes, ignore +; Default character encountered +read_one: + mov bx,index ;bx = port buffer index + cmp bx,buf_len ;have we exceeded buffer boundary? + jl read_420 ; no, jump + call zbell ; yes, sound beep + jmp read_001 ; and continue +read_420: + call echo_ch ;echo character to display + jmp read_001 ;go handle next read +; finished reading from window +read_done: + call zcuroff ;turn off the cursor + mov ax,index ;return length + pop bp + ret +read_win endp + +;***************************************************************************** +; Move the string in port object to buffer sh_bufer +;***************************************************************************** +str_str proc near + lea di,sh_bufer ;di=address of shadow buffer +; Move the characters + push si ;tempsave si + add si,pt_buffr ;port buffer address + mov cx,index ;cx = buffer length + mov AX,ES + mov BX,DS + mov ES,BX ;es:di => shadow buffer + mov DS,AX ;ds:si => port buffer +rep movsb ;move 'em out + mov es,ax ;reset segment registers + mov ds,bx + lea di,sh_bufer ;di => shadow buffer + pop si ;si => port object + ret +str_str endp +;***************************************************************************** +; Echo single character +; Entry : al = character to display +; es:si => current port object +;***************************************************************************** +echo_ch proc near + mov bx,index ;bx = index within port buffer + mov byte ptr es:[si+bx+pt_buffr],al ;store character + inc bx ;bump index + mov index,bx ; and update + cmp insert_m,0 ;insert mode? + jne echo_10 ; yes, jump + inc sh_ptr ;bump shadow buffer index +echo_10: + mov cx,es:[si].pt_cline ;cx = current column + mov dx,es:[si].pt_ccol ;dx = current line + cmp dx,es:[si].pt_ncols ;reached end of line? + jl echo_20 ; no, jump + inc cx ;bump current line + xor dx,dx ;clear current col +echo_20: + lea di,row ;ds:di => row vector + cmp cx,es:[si].pt_nline ;exceed number lines? + jl echo_50 ; no, jump + push es:[si].pt_text ;text attribute + push es:[si].pt_ncols ;number columns + push es:[si].pt_nline ;number lines + push es:[si].pt_ulcol ;upper left col + push es:[si].pt_ullin ;upper left line + call zscroll ;scroll up one line + add sp,10 ;dump args + mov cx,es:[si].pt_nline + dec cx ;update current line + xor dx,dx ;clear current column +; Decrement the contents of row vector + push ax ;tempsave character + push bx ;tempsave buffer index + mov ax,bx ;ax = port buffer index + xor bx,bx ;bx = buffer start +echo_30: cmp bx,ax ;have we reached buffer end + jge echo_40 ; yes, jump + dec byte ptr [di+bx] ;decrement row for character + inc bx ;index for next character + jmp echo_30 ;loop till done +echo_40: pop bx ;restore buffer index + pop ax ;restore character +;update row/col vector for this character +echo_50: + dec bx ;create index into row/col vectors + mov byte ptr [di+bx],cl ;update row + lea di,column + mov byte ptr [di+bx],dl ;update col + cmp al,TAB ;is character the tab key? + jne echo_100 ; no, jump +; Process the TAB key + mov ax,dx ;ax = current column + mov bx,8 ;bx = tab spacing + div bl ;ah = remainder (cur_col % 8) + sub bl,ah ;bx = 8 - remainder + add dx,bx ;dx = (new) current column + cmp dx,es:[si].pt_ncols ;exceeded line length? + jle echo_60 ; no, jump + mov dx,es:[si].pt_ncols ; yes, current col = end of line +echo_60: + mov es:[si].pt_ccol,dx ;update current col + mov es:[si].pt_cline,cx ;update current line + + mov bx,dx ;bx = current column + add bx,es:[si].pt_ulcol ;bx = column within window + cmp bx,SCREEN_WIDTH ;off of screen? + jl echo_ret ; no, jump + mov bx,(SCREEN_WIDTH - 1) ; yes, current col = last col + pushm + call zputcur ;position cursor + add sp,4 ;dump args + jmp echo_ret ;return +; Process the non-TAB key +echo_100: + mov es:[si].pt_cline,cx ;update current line + add cx,es:[si].pt_ullin ;cx = current lin relative to window + mov es:[si].pt_ccol,dx ;update current line + add dx,es:[si].pt_ulcol ;dx = current col relative to window + + push es:[si].pt_text ;text attribute + push ax ;character to display + push dx ;column + push cx ;line + call zputc ;display character + add sp,8 ;dump args + inc es:[si].pt_ccol ;update port's current column +echo_ret: + ret +echo_ch endp +;************************************************************************* +; Push a single character back into the input buffer +;************************************************************************* + public pushchar +pushchar proc near + push es + push si + + LoadPage es,port_pg + mov si,port_ds ;es:si => port object + + cmp es:[si].pt_bfpos,0 ;any chars in buffer? + jle push_err ; no, error + dec es:[si].pt_bfpos ;position to prio character +push_ret: + pop si + pop es + ret +push_err: + lea bx,push_er ;bx = address of error msg + push bx ;pass to print routine + C_call printf,,Load_ES ;print error message + add sp,2 ;dump args + C_call force_de,,Load_ES ;envoke debugger + add sp,2 ;will we ever return here??? + jmp push_ret +pushchar endp + +rd_proc proc near +;************************************************************************* +; Support for read-char-ready? +;************************************************************************* + public rd_ch_rd + public read_cha +rd_ch_rd: + lods byte ptr es:[si] ;get register + save ;save vm instruction pointer + add ax,offset reg0 ;compute register address + mov di,ax + save ;save register argument for later + xor cx,cx + push cx + push ax + C_call get_port,,Load_ES ;get port object + ;port returned in tmp_page:tmp_disp + mov sp,bp ;dump args + test ax,ax ;check return status + jz rd_010 ; no errors, continue + jmp rd_err ; else jump to error handler +rd_010: + restore ;restore register argument + mov [di].C_page,SPECCHAR*2 ;prepare to return a character + mov si,tmp_disp + LoadPage es,tmp_page ;get page address + mov bx,es:[si].pt_bfpos ;bx = buffer index + cmp bx,es:[si].pt_bfend ;if at buffer end + jge rd_020 ; then go fill the buffer +;get character from port object buffer + xor ah,ah + mov al,byte ptr es:[si+pt_buffr+bx] ;get the character +rd_T: + cmp al,CTRL_Z ;control-z character? + jne rd_015 ; no, continue + test es:[si].pt_pflgs,BINARY ;binary file? + jnz rd_015 ; yes, continue + jmp rd_eof ; no, return eof char +rd_015: mov [di].C_disp,ax ;return the character + jmp next_SP +; no character in input buffer +rd_020: + test es:[si].pt_pflgs,WINDOW ;window port? + jz rd_030 ; no, jump + jz rd_030 + call char_rdy ;check for character at console + test ax,ax ;was one there? + jz rd_no ; no, jump + xor ah,ah + jmp rd_T ;go process +; no character available -- return '() +rd_no: xor ax,ax + mov [DI].C_page,ax + mov [DI].C_disp,ax + jmp next_SP +; not a window +rd_030: + test es:[si].pt_pflgs,OPEN ;is the port open? + jz rd_no ; no, return '() + pushm + call ssetadr ;set up port address + mov sp,bp ;dump args + call take_ch ;get a character + mov sp,bp ;dump args + restore ;di => register for return + cmp ax,256 ;eof? + jne rd_033 ; no, continue + jmp rd_eof ; yes, go process it +rd_033: + call pushchar ; no, put it back + mov sp,bp + jmp rd_015 + +; Wrong port object, display error message +rd_err: lea BX,ch_rd + jmp src_err ; link to error handler + +;;;************************************************************************ +;;; Support for read-char +;;;************************************************************************ +read_cha: + lods byte ptr es:[si] ;get register + save ;save vm instruction pointer + add ax,offset reg0 ;compute register address + mov di,ax + save ;save register argument for later + xor cx,cx + push cx + push ax + C_call get_port,,Load_ES ;get port object + ;port returned in tmp_page:tmp_disp + mov sp,bp ;dump args + test ax,ax ;check return status + jz rc_010 ; no errors, continue + jmp rc_err ; else jump to error handler +rc_010: + restore + mov [di].C_page,SPECCHAR*2 ;prepare to return character + mov si,tmp_disp + LoadPage es,tmp_page ;es:si => port object + mov bx,es:[si].pt_pflgs ;get port flags + test bx,WINDOW ;window port? + jz rc_050 ; no, jump + test bx,STRIO ;string port? + jnz rc_050 ; yes, jump +;read from window + mov cx,es:[si].pt_bfpos ;cx = port buffer index + cmp cx,es:[si].pt_bfend ;any character in buffer? + jl rc_050 ; no, jump + mov cx,es:[si].pt_cline + add cx,es:[si].pt_ullin ;cx = line + mov dx,es:[si].pt_ccol + add dx,es:[si].pt_ulcol ;dx = column + pushm + call zputcur ;position cursor + mov sp,bp ;dump args + call zcuron ;enable cursor + call getch ;get character from console + mov [di].C_disp,ax ;return character in reg + mov byte ptr es:[si].pt_buffr,al ;store also in port object + call zcuroff ;disable cursor + mov bx,1 + mov es:[si].pt_bfpos,bx ;update port position + mov es:[si].pt_bfend,bx + jmp next_SP +;read from port object +rc_050: + pushm + call ssetadr ;set port address + mov sp,bp + call take_ch ;take one character + mov sp,bp + restore + cmp ax,256 ;eof character? + je rd_eof ; yes, jump + jmp rd_015 ; no, return the character +; +rd_eof: mov [di].C_page,EOF_PAGE*2 ; no, return eof character + mov [di].C_disp,EOF_DISP + jmp next_SP +; +rc_err: lea BX,rch_er ; address of error message + jmp src_err ; jump to error handler +rd_proc endp + +prog ends + end + \ No newline at end of file diff --git a/prosmmu.asm b/prosmmu.asm new file mode 100644 index 0000000..569f4f8 --- /dev/null +++ b/prosmmu.asm @@ -0,0 +1,268 @@ + name PROSMMU + title Scheme Memory Management Utilities for Protected Mode + page 62,132 +; =====> PROSMMU.ASM +;**************************************************************** +;* TIPC Scheme '84 Memory Management Utilities * +;* * +;* (C) Copyright 1985 by Texas Instruments Incorporated. * +;* All rights reserved. * +;* * +;* Author: Terry Caudill * +;* Date written: 17 Feb 1987 * +;**************************************************************** + include schemed.equ + include schemed.ref + include schemed.mac + +DOS equ 021h + +DGROUP group data +PGROUP group prog + +data segment word public 'DATA' + assume ds:DGROUP + extrn page0:byte, page4:byte, page5:byte, page6:byte + extrn page7:byte, page8:byte + + extrn _top:word, _paras:word,first_pa:word,first_dos:word + + public scheme_heap,gc_ing +scheme_heap dw 0 ;selector for entire scheme heapspace +gc_ing dw 0 ;denotes when gc is taking place + +sub_segerr db "Error allocating data segment",0Ah,0 +alloc_err db "Unable to allocate memory for scheme heap",0Ah,0 + +data ends + + +prog segment byte public 'PROG' + assume cs:PGROUP + +;;====================================================================== +;; +;; Get page base address of page +;; +;;====================================================================== + + public getbase +getbase proc near + push BP + mov BP,SP + mov BX,word ptr [BP+4] + mov AX,word ptr [BX+pagetabl] ;; Get table indicator + pop BP + ret + +getbase endp + +;;====================================================================== +;; +;; InitMem() +;; Compute the best page size, but not smaller than MIN_PAGESIZE +;; +;;====================================================================== + + + + + public InitMem +InitMem proc near + push BP + sub SP,2 ;; Allocate loacl storage + mov BP,SP + + mov word ptr [bp+0],0 ;; number of pages allocated + + mov bx,ds + mov es,bx ;; ensure ES = DS + +;; The first eight pagetable entries contain offsets to data within +;; the local data segment. These offsets must be changed to to +;; selectors so that they can be accessed as any other scheme object. + +;; Convert offset within pagetabl[0] into paragraph address + + mov di,offset pagetabl + + xor si,si + mov bx,word ptr [di] ;; si:bx = offset within DS + xor cx,cx + mov dx,16 ;; cx:dx = length + mov ax,0E801h ;; Create Data Window + int DOS + jc subsegerr + mov word ptr [di],ax ;; move selector into pagetabl + +;; Now convert pagetabl[4] through pagetabl[8] + + mov dx,5 ;; dx = # entries to modify + mov di,offset pagetabl[8] +EmmP$0: + push dx + mov bx,word ptr [di] ;; si:bx = offset within ds + xor cx,cx ;; cx:dx = length + mov dx,0600h ;; (big enough for largest page) + mov ax,0E801h ;; Create Data Window + int DOS + pop dx ;; get # entries + jc subsegerr + mov word ptr [di],ax ;; move selector into pagetabl + add di,2 ;; address next pagetable entry + dec dx ;; any remaining? + jnz EmmP$0 ;; yes, loop + jmp around_error +subsegerr: + lea bx,sub_segerr + jmp FatalError + +around_error: +;; Now we must allocate the remaining memory (to approx. 4mb), and fill +;; the remaining pagetabl entries with selectors to address each page. + +;; ask for too much memory, # bytes available will be returned in cx:dx + mov cx,0ffffh + mov dx,0ffffh ;; cx:dx = # bytes requested + mov ax,0E800h ;; create data segment + int 021h ;; extended dos function from AIA + + mov ax,dx + mov dx,cx ;; dx:ax = # bytes available + push ax + push dx ;; save for later + +;; calculate #paragraphs available + mov cx,4 ;; cx = shift count +make_para: + shr dx,1 + rcr ax,1 + loop make_para +;; lets make the pagesize a multiple of 2000h bytes (this is so that when +;; pages must be merged to hold large objects, there will be no wasted +;; space). + mov cx,NUMPAGES-PreAlloc ;; cx = number pagetabl entrys available + idiv cx + mov bx,ax ;; bx = # paras per page + mov ax,200h + cmp ax,bx ;; if #paras/page < 200 paras + jge make_pagesize ;; round to 200, jump + mov ax,400h ;; if #paras/page < 400 paras + cmp ax,bx ;; round to 400, jump + jge make_pagesize + mov ax,7FFh ;; default pagesize to 7FF0 bytes +;; change the paras used in calculations above to bytes +make_pagesize: + mov cx,4 + shl ax,cl ;; dx = number bytes per page + mov pagesize,ax ;; save away in pagesize +;; divide the # bytes available by the #bytes/page to see how many +;; pages will be required. max = NUMPAGES-PreAlloc + mov cx,ax ;; cx = # bytes/page + pop dx + pop ax ;; dx:ax = # bytes available + idiv cx ;; ax = # pages required + cmp ax,NUMPAGES-PreAlloc ;; do we exceed number avail page? + jle Emmp$0a ;; no, jump + mov ax,NUMPAGES-PreAlloc ;; yes, just fill the table +Emmp$0a: + xor dx,dx + mul cx ;; dx:ax = total memory rquirements + +;; Allocate only enough memory for the pagetable. Initially allocate just +;; one segment large enough to hold all the scheme heap. + push cx ;;tempsave bytes/page + mov cx,dx + mov dx,ax ;; cx:dx = length + mov ax,0E800h ;; Create Data Segment + int DOS + pop bx ;;restore bytes/page + jnc Emmp$0b +allocerr: + lea bx,alloc_err + jmp FatalError +Emmp$0b: + mov scheme_heap,ax ;; save selector to scheme heap + +;; Now allocate multiple "windows" within this larger segment. The pages +;; may overlap so that we can merge pages to hold objects that are larger +;; than a single page. In AI Archiects terminology, we will allocate +;; "pages" of 8000h (large enough for our largest object) with a "stride" +;; of our desired pagesize (this causes overlap every pagesize number of +;; bytes. The call below will return a selector to the starting page, +;; and the number of selectors necessary to cover the entire segment. +;; +;; Warning: ds register does not address our data segment below +;; + mov ds,ax ;; ds = large segment + xor cx,cx + mov dx,08000h ;; cx:dx = size of each page + xor si,si ;; si:bx = stride + push bx ;; save page size + mov AX,0EA00h ;; Allocate Multiple Windows + int DOS ;; extended Dos func from AIA + pop si ;; restore page size + push ss + pop ds + jc allocerr ;; if error, exit +;; +;; Warning: ds register does not address our data segment above +;; +;; ax = first selector, bx = number of selectors, si=page size +;; loop number of selector times, filling the pagetabl with +;; selectors to the memory. selectors are 8 bytes in length +;; so bump each selector by 8 to get to the next one. + + mov dx,nextpage ;; Next page table entry + mov freepage,dx ;; is also next free page + mov first_pa,dx ;; save for rlsexp, sbid + mov cx,bx ;; cx = number of pages to fill + jcxz Emmp$2 ;; if no pages, jump +EmmP$1: + mov bx,dx + shl bx,1 ;; bx = page index + mov word ptr ss:pagetabl[BX],AX ;; Save selector in table + and word ptr ss:attrib[BX],not NOMEMORY ;; mark as allocated + mov word ptr ss:psize[BX],si ;; note its size + inc dx ;; and update for next page + mov word ptr ss:pagelink[BX],dx ;; update page link + mov word ptr ss:nextcell[BX],0 ;; clear free chain pointer + inc word ptr [bp+0] ;; page_count++ + add ax,8 ;; next selector + loop EmmP$1 ;; get next selector +EmmP$2: + mov nextpage,dx ;; set up nextpage + mov lastpage,dx ;; lastpage = nextpage + pop ax ;; return number pages allocated + pop bp + ret +FatalError: + mov ax,ss ;; ensure ds=es=ss + mov ds,ax + mov es,ax + push bx ;; push error message + C_call print_an ;; print message and quit +InitMem endp + +;;====================================================================== +;; +;; rlsexp - Release Dos Allocated Pages +;; +;;====================================================================== + public rlsexp +rlsexp proc near + push ES + push BP + mov BP,SP + mov es,scheme_heap ;; es = slector for scheme heap + mov AX,4900h ;; free allocated memory + int DOS ;; do it + pop BP + pop ES + ret +rlsexp endp + +prog ends + + end + \ No newline at end of file diff --git a/sources/errhand.s b/sources/errhand.s new file mode 100644 index 0000000..6841e15 --- /dev/null +++ b/sources/errhand.s @@ -0,0 +1,73 @@ +; +; The following code is an example of an error handler for I/O errors. The +; function open-input-file attempts to open filename for input. Note that +; a continuation is saved in the fluid variable my%ioerr before the call to +; open-input-file. Upon return from the open, the variable port is +; interrogated to determine the status- To retry the operation with the same +; filename, retry the operation with a different filename, or return the port +; object. +; + +(define (open-input-file filename) + (let ((port (call/cc + (fluid-lambda (my%ioerr) + ((access open-input-file user-global-environment) + filename))))) + (cond ((eq? port 'retry) + (open-input-file filename)) + ((string? port) + (open-input-file port)) + (else + port)))) + +; +; *USER-ERROR-HANDLER* has been designed to trap on all I/O errors, pop up a +; window to indicate the error, and illicit a response from the user. The +; result is then returned via the continuation bound to the fluid variable +; my%ioerr. The system error handler is called for all other errors. +; +; See the User's Guide for a discussion on user error handling and a list of +; all I/O errors. +; + +(set! (access *user-error-handler* user-global-environment) + (lambda (error-num error-msg irritant sys-error-handler) + (if (and (fluid-bound? my%ioerr) + (number? error-num) + (>= error-num 1) + (<= error-num 88)) + (let ((win (make-window error-msg #t)) + (result '())) + (window-set-position! win 10 10) + (window-set-size! win 6 50) + (window-set-cursor! win 2 5) + (window-popup win) + (case error-num + ((2 3) ;file/path not found + (display "File/Path not found : " win) + (display irritant win) + (newline win) + (display "Enter new pathname (or return to exit) - " win) + (set! result (read-line win)) + (if (string=? result "") + (set! result '()))) + ((21) ;drive not ready + (display "Drive not ready - Retry (y/n)?" win) + (set! result + (if (char=? (char-upcase (read-char win)) #\Y) + 'retry + '()))) + (else + (display "Extended Dos I/O Error - " win) + (display irritant win) + (newline win) + (newline win) + (char-upcase (read-char win)) + (set! result '()))) + + (window-popup-delete win) + ((fluid my%ioerr) result)) + ;else + (sys-error-handler)))) + + \ No newline at end of file diff --git a/sources/extend.s b/sources/extend.s new file mode 100644 index 0000000..8aab54d --- /dev/null +++ b/sources/extend.s @@ -0,0 +1,340 @@ +;;; extend.s + +;;; Copyright (c) 1986 R. Kent Dybvig +;;; Permission to copy this software, in whole or in part, to use this +;;; software for any lawful purpose, and to redistribute this software +;;; is granted subject to the restriction that all copies made of this +;;; software must include this copyright notice in full. + +;;; +;;; EXTEND-SYNTAX is a syntax extension facility based on pattern match- +;;; ing. The extend-syntax code presented here was contributed by R. Kent +;;; Dybvig, as implemented for Chez Scheme and described in his book, +;;; The Scheme Programming Language. The code has been modified to run +;;; under TI Scheme. +;;; +;;; Methods similar to extend-syntax exist in most implementations of +;;; Scheme, including TI Scheme's own SYNTAX special form. EXTEND-SYNTAX +;;; however, is much more powerful in its capabilities than SYNTAX. A full +;;; description of extend-syntax is beyond the scope of this documentation. +;;; Other than some examples I will list here, I must refer you to Kent's +;;; book or other documents for further information on EXTEND-SYNTAX. For +;;; those of you already familiar with extend-syntax, its basic syntax is: +;;; +;;; (extend-syntax (name key ...) (pattern optional-fender expansion) ...) +;;; +;;; Examples: +;;; +;;; (extend-syntax (when) +;;; ((when test exp1 exp2 ...) +;;; (if test (begin exp1 exp2 ...) #F))) +;;; +;;; (extend-syntax (let) +;;; ((let ((x v) ...) e1 e2 ...) +;;; ((lambda (x ...) e1 e2 ...) v ...))) +;;; +;;; +;;; NOTE - You may use EXPAND to see an expansion of an extend-syntax +;;; definition. See the READ.ME file for explanation of EXPAND. +;;; + + +(macro unless + (lambda (e) + (append (list 'when (list 'not (cadr e))) (cddr e)))) + +(define-structure %%boxed-obj value) + +(define box (lambda (objct) (make-%%boxed-obj 'value objct))) + +(define unbox (lambda (box) (if (%%boxed-obj? box) + (%%boxed-obj-value box) + (error "Object referenced is not a BOX" box)))) + +(define set-box! (lambda (box objct) + (if (%%boxed-obj? box) + (set! (%%boxed-obj-value box) objct) + (error "Object to be set is not a BOX" box)))) + + +(define %%map2 + (lambda (f a1 a2) + (let loop ((result ()) + (a1 a1) + (a2 a2)) + (if (null? a1) + (reverse! result) + (loop (cons (f (car a1) (car a2)) result) + (cdr a1) + (cdr a2)))))) + +(macro %%multi-mapper + (lambda (x) + (cond ((syntax-match? '(%%multi-mapper) '(%%multi-mapper f a1 ...) x) + (let ((g10 (map (lambda (x) (gensym)) + (cddr x)))) + (quasiquote (let loop ((result ()) + (unquote-splicing + (%%map2 (lambda (g9 g11) + (quasiquote ((unquote g11) + (unquote g9)))) + (cddr X) g10))) + (if (or (unquote-splicing + (map (lambda (g11) + (quasiquote + (null? (car (unquote g11))))) + g10))) + (reverse! result) + (loop (cons ((unquote (cadr x)) + (unquote-splicing + (map (lambda (g11) + (quasiquote + (car (unquote g11)))) + g10))) + result) + (unquote-splicing + (map (lambda (g11) + (quasiquote (cdr (unquote g11)))) + g10)))))))) + (else (error "%%MULTI-MAPPER: invalid syntax " x))))) + + +(define %%make-syntax + (letrec + ((id-name car) + (id (lambda (name accessor control) (list name accessor control))) + (id-accessor cadr) + (id-control caddr) + (loop (lambda () (box '()))) + (loop-ids unbox) + (loop-ids! set-box!) + (c...rs + `((car caar . cdar) + (cdr cadr . cddr) + (caar caaar . cdaar) + (cadr caadr . cdadr) + (cdar cadar . cddar) + (cddr caddr . cdddr) + (caaar caaaar . cdaaar) + (caadr caaadr . cdaadr) + (cadar caadar . cdadar) + (caddr caaddr . cdaddr) + (cdaar cadaar . cddaar) + (cdadr cadadr . cddadr) + (cddar caddar . cdddar) + (cdddr cadddr . cddddr))) + (add-car + (lambda (accessor) + (let ((x (and (pair? accessor) (assq (car accessor) c...rs)))) + (if (null? x) + `(car ,accessor) + `(,(cadr x) ,@(cdr accessor)))))) + (add-cdr + (lambda (accessor) + (let ((x (and (pair? accessor) (assq (car accessor) c...rs)))) + (if (null? x) + `(cdr ,accessor) + `(,(cddr x) ,@(cdr accessor)))))) + (parse + (lambda (keys pat acc cntl) + (cond + ((symbol? pat) + (if (memq pat keys) + '() + (list (id pat acc cntl)))) + ((pair? pat) + (if (equal? (cdr pat) '(...)) + (let ((x (gensym))) + (parse keys (car pat) x (id x acc cntl))) + (append (parse keys (car pat) (add-car acc) cntl) + (parse keys (cdr pat) (add-cdr acc) cntl)))) + (else '())))) + + (gen + (lambda (exp ids loops) + (cond + ((symbol? exp) + (let ((id (lookup exp ids))) + (if (null? id) + exp + (begin + (add-control! (id-control id) loops) + (list 'unquote (id-accessor id)))))) + ((pair? exp) + (cond + ((eq? (car exp) 'with) + (unless (syntax-match? '(with) '(with ((p x) ...) e ...) exp) + (error "EXTEND-SYNTAX: invalid 'with' form" exp)) + (list 'unquote + (gen-with + (map car (cadr exp)) + (map cadr (cadr exp)) + (caddr exp) + ids + loops))) + ((and (pair? (cdr exp)) (eq? (cadr exp) '...)) + (let ((x (loop))) + (make-loop + x + (gen (car exp) ids (cons x loops)) + (gen (cddr exp) ids loops)))) + (else + (let ((a (gen (car exp) ids loops)) + (d (gen (cdr exp) ids loops))) + (if (and (pair? d) (eq? (car d) 'unquote)) + (list a (list 'unquote-splicing (cadr d))) + (cons a d)))))) + (else exp)))) + + (gen-with + (lambda (pats exps body ids loops) + (if (null? pats) + (make-quasi (gen body ids loops)) + (let ((p (car pats)) (e (car exps)) (g (gensym))) + `(let ((,g ,(gen-quotes e ids loops))) + ,(gen-with + (cdr pats) + (cdr exps) + body + (append (parse '() p g '()) ids) + loops)))))) + + (gen-quotes + (lambda (exp ids loops) + (cond + ((syntax-match? '(quote) '(quote x) exp) + (make-quasi (gen (cadr exp) ids loops))) + ((pair? exp) + (cons (gen-quotes (car exp) ids loops) + (gen-quotes (cdr exp) ids loops))) + (else exp)))) + + (lookup + (lambda (sym ids) + (let ((x (mem (lambda (x) (eq? (id-name x) sym)) ids))) + (and x (car x))))) + + (add-control! + (lambda (id loops) + (unless (null? id) + (when (null? loops) + (error "EXTEND-SYNTAX: missing ellipsis in expansion")) + (let ((x (loop-ids (car loops)))) + (unless (memq id x) + (loop-ids! (car loops) (cons id x)))) + (add-control! (id-control id) (cdr loops))))) + + (make-loop + (lambda (loop body tail) + (let ((ids (loop-ids loop))) + (when (null? ids) + (error "EXTEND-SYNTAX: extra ellipsis in expansion")) + (cond + ((equal? body (list 'unquote (id-name (car ids)))) + (if (null? tail) + (list 'unquote (id-accessor (car ids))) + (cons (list 'unquote-splicing (id-accessor (car ids))) + tail))) + ((and (null? (cdr ids)) + (syntax-match? '(unquote) '(unquote (f x)) body) + (eq? (cadadr body) (id-name (car ids)))) + (let ((x `(%%multi-mapper ,(caadr body) ,(id-accessor (car ids))))) + (if (null? tail) + (list 'unquote x) + (cons (list 'unquote-splicing x) tail)))) + (else + (let ((x `(%%multi-mapper (lambda ,(map id-name ids) ,(make-quasi body)) + ,@(map id-accessor ids)))) + (if (null? tail) + (list 'unquote x) + (cons (list 'unquote-splicing x) tail)))))))) + + (make-quasi + (lambda (exp) + (if (and (pair? exp) (eq? (car exp) 'unquote)) + (cadr exp) + (list 'quasiquote exp)))) + + (make-clause + (lambda (ks cl x) + (cond + ((syntax-match? '() '(pat fender exp) cl) + (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl))) + (let ((ids (parse ks pat x '()))) + `((and (syntax-match? ',ks ',pat ,x) + ,(gen-quotes fender ids '())) + ,(make-quasi (gen exp ids '())))))) + ((syntax-match? '() '(pat exp) cl) + (let ((pat (car cl)) (exp (cadr cl))) + (let ((ids (parse ks pat x '() ))) + `((syntax-match? ',ks ',pat ,x) + ,(make-quasi (gen exp ids '())))))) + (else + (error "EXTEND-SYNTAX: invalid clause" cl))))) + (make-syntaxer + (let ((x (string->uninterned-symbol "x"))) + (lambda (keys clauses) + `(lambda (,x) + (cond + ,@(map (lambda (cl) + (make-clause keys cl x)) clauses) + (else + (error (string-append (symbol->string ',(car keys)) + ": invalid syntax") ,x)))))))) + make-syntaxer)) + +(define mem + (lambda (f alist) + (let loop ((l alist)) + (if (null? l) + '() + (if (f (car l)) + l + (loop (cdr l))))))) + +; (define-syntax-expander extend-syntax ;Original code in body of letrec +; (lambda (x e) +; (let ((keys (cadr x)) (clauses (cddr x))) +; (e `(define-syntax-expander ,(car keys) +; ,(make-syntax keys clauses)))))) + + + +(macro extend-syntax + (lambda (x) + (let ((keys (cadr x)) + (clauses (cddr x))) + `(macro ,(car keys) ,(%%make-syntax keys clauses))))) + + +; (define-syntax-expander extend-syntax/code ;original code in body of letrec +; (lambda (x e) +; (let ((keys (cadr x)) (clauses (cddr x))) +; `',(make-syntax keys clauses))))) + +(macro extend-syntax/code + (lambda (x) + (let ((keys (cadr x)) (clauses (cddr x))) + `',(%%make-syntax keys clauses)))) + +;;; syntax-match? is used by extend-syntax to choose among clauses and +;;; to check for syntactic errors. It is also available to the user. + +(define syntax-match? + (lambda (keys pat exp) + (cond + ((symbol? pat) (if (memq pat keys) (eq? exp pat) #!true)) + ((pair? pat) + (if (equal? (cdr pat) '(...)) + (let f ((lst exp)) + (or (null? lst) + (and (pair? lst) + (syntax-match? keys (car pat) (car lst)) + (f (cdr lst))))) + (and (pair? exp) + (syntax-match? keys (car pat) (car exp)) + (syntax-match? keys (cdr pat) (cdr exp))))) + (else (equal? exp pat))))) + + + \ No newline at end of file diff --git a/sources/macros.s b/sources/macros.s new file mode 100644 index 0000000..410f2b5 --- /dev/null +++ b/sources/macros.s @@ -0,0 +1,111 @@ +; +; Following are a few macro definitions which implement constructs in other +; LISPs. They are not intended to be fully compatible to COMMON LISP or any +; other dialect, but are included as examples of how other constructs may +; be implemented, and how Scheme itself can be extended. Note also that the +; examples lack sufficient error checking - feel free to modify, extend, +; and add to any or all of macros for your own purposes. +; + +; +; CATCH/THROW - A catch form evaluates some subforms in such a way that, if +; a throw is executed during such evaluation, the evaluation is aborted at +; that point and the catch form returns a value specified by the throw. The +; catch/throw mechanism works even if the throw form is not within the lexical +; scope of the catch. +; +; The tags used for this implementation of catch/throw can be either symbols, +; strings, or numbers. Note the use of fluids and continuations in this +; implementation. +; + +(macro catch ;(catch tag expression) + (lambda (e) + (let ((tag (cadr e)) + (form (caddr e))) + (cond ((string? tag) + (set! tag (string->symbol tag))) + ((number? tag) + (set! tag (implode (explode tag)))) + ((and (pair? tag) (eq? (car tag) 'quote)) + (set! tag (cadr tag))) ) + + `(call/cc (fluid-lambda (,tag) ,form))))) + + +(macro throw ;(throw tag value) + (lambda (e) + (let ((tag (cadr e)) + (value (caddr e))) + (cond ((string? tag) + (set! tag (string->symbol tag))) + ((number? tag) + (set! tag (implode (explode tag)))) + ((and (pair? tag) (eq? (car tag) 'quote)) + (set! tag (cadr tag))) ) + + `(if (and (fluid-bound? ,tag) + (continuation? (fluid ,tag))) + ((fluid ,tag) ,value) + (error "Bad tag on throw" ,tag))))) + +; +; PROG - The prog construct allows one to write in a statement-oriented style +; (ala FORTRAN), using go statements that can refer to tags in the body of the +; prog. Modern LISP programming tends to use prog infrequently, however the +; following exercise is a good example of how Scheme may be extended to take +; on characteristics of other LISPs. +; + +(macro go + (lambda (form) + (if (integer? (cadr form)) + `(implode (explode ,(cadr form))) + ;else + (cdr form)))) + +(macro prog + (lambda (form) + (letrec + ((tagstart '()) + (buildvars + (lambda (proglist varlist) + (if (null? proglist) + varlist + ;else + (buildvars (cdr proglist) + (if (pair? (car proglist)) + `(,(car proglist) ,@varlist) + ;else + `( (,(car proglist) '()) ,@varlist)))))) + (buildtags + (lambda (tbodys) + (if (null? tagstart) + tbodys + ;else + (buildtags + `( ( ,(car tagstart) + (lambda () ,@(getbody (cdr tagstart) '()))) + ,@tbodys))))) + (getbody + (lambda (exprs body) + (cond ((null? exprs) + (set! tagstart '()) + (reverse! `((return ()) ,@body))) + ((or (symbol? (car exprs)) (integer? (car exprs))) + (set! tagstart + (if (integer? (car exprs)) + `(,(implode (explode (car exprs))) ,@(cdr exprs)) + ;else + exprs)) + (reverse! `( (,(car tagstart)) ,@body))) + (else + (getbody (cdr exprs) `(,(car exprs) ,@body))))))) + + (let ((letrec_body (getbody (cddr form) '())) + (letrec_vars (reverse! (buildtags (buildvars (cadr form) '()))))) + + `(call/cc (lambda (return) + (letrec ,letrec_vars ,@letrec_body)))) ))) + + \ No newline at end of file diff --git a/sources/newwin.s b/sources/newwin.s new file mode 100644 index 0000000..82fa584 --- /dev/null +++ b/sources/newwin.s @@ -0,0 +1,158 @@ +; Window and attribute functions for PC Scheme +; Copyright 1987,1988 (c) Texas Instruments + + +;; NEW-WINDOW - new version for 3.02 + +; NEW-WINDOW creates a window interactively. The cursor can be moved +; around to mark the upper left hand and lower right hand corners of the +; window. The window port object is returned. +; +; This function demonstrates how to create a non-destructive cursor +; in PC Scheme by using a popup window of size 1x1. +; +; Example: (new-window "A Window") -> port object + +;; Create a new window using the cursor keys and return the port object. +;; The cursor keys position the corner markers, return accepts the +;; marker's position, and any other key exits with no change. +;; "minrows" and "mincols" say that the window will be at least that big. +;; The window is displayed immediately unless the symbol NO-DISPLAY is used. +;; The new window always has a border. +;; syntax: (NEW-WINDOW title [minrows] [mincols] ['NO-DISPLAY]) +(define (new-window title . rest) + (let ((minrows (or (car rest) 0)) + (mincols (or (cadr rest) 0)) + (no-display (memq 'no-display rest))) + (call/cc + (lambda (exit) + (letrec ((ulc (integer->char 218)) + (rlc (integer->char 217)) + (left #\K) + (up #\H) + (right #\M) + (down #\P) + (accept #\return) + (hold '()) + (cursor + (let ((w (make-window "" #!false))) + (window-set-size! w 1 1) + w)) + (read-char-1 + (lambda () + (let ((char (read-char cursor))) + (if (char=? char (integer->char 0)) + (read-char cursor) char)))) + (mark-corner + (lambda (uly ulx lry lrx ch) ;note y,x means row,col + (let loop ((r uly) + (c ulx)) + (window-set-position! cursor r c) + (window-popup cursor) + (display ch cursor) + (window-set-cursor! cursor 0 0) + (let ((char (read-char-1))) + (window-popup-delete cursor) + (cond ((eqv? char left) + (loop r (if (>= (-1+ c) ulx) (-1+ c) c))) + ((eqv? char up) + (loop (if (>= (-1+ r) uly) (-1+ r) r) c)) + ((eqv? char right) + (loop r (if (< (1+ c) lrx) (1+ c) c))) + ((eqv? char down) + (loop (if (< (1+ r) lry) (1+ r) r) c)) + ((eqv? char accept) + (window-set-cursor! cursor 0 0) + (set! hold + (list (window-save-contents cursor) r c)) + (display ch cursor) + (cons r c)) + (else + (and hold + (let ((char (car hold)) + (r (cadr hold)) + (c (caddr hold))) + (window-set-position! cursor r c) + (window-restore-contents cursor char))) + (exit #!false)))))))) + (let* ((uly (car (window-get-position (current-output-port)))) + (ulx (cdr (window-get-position (current-output-port)))) + (lry (+ uly (car (window-get-size (current-output-port))))) + (lrx (+ ulx (cdr (window-get-size (current-output-port))))) + (ulc-position (mark-corner uly ulx + (- lry minrows) (- lrx mincols) + ulc)) + (new-uly (car ulc-position)) + (new-ulx (cdr ulc-position)) + (rlc-position (mark-corner (+ new-uly minrows) + (+ new-ulx mincols) lry lrx rlc)) + (new-lry (car rlc-position)) + (new-lrx (cdr rlc-position)) + (new-width (1+ (- new-lrx new-ulx))) + (new-height (1+ (- new-lry new-uly))) + (w (make-window title t))) + (window-set-position! w new-uly new-ulx) + (window-set-size! w new-height new-width) + (or no-display (window-clear w)) + w)))))) + + + +; ATTR takes a list of attribute names and converts them to the +; equivalent attribute number suitable for PC Scheme's attribute +; functions. It works with both TI and IBM (CGA only). +; +; Examples: (attr) ;returns default value +; (attr '(red blink)) ;returns number for blinking red text; +; ;exact number depends on the machine type +; (attr 'ti '(red blink)) ;ignore machine type, get attr# for TI +; (attr 'ibm '(red blink)) ;ignore machine type, get attr# for IBM +; +(define ATTR + (let ((attrs-ibm '((blink . 128) (bkg-white . 112) + (bkg-brown . 96) (bkg-magenta . 80) (bkg-cyan . 48) + (bkg-red . 64) (bkg-green . 32) (bkg-blue . 16) + (light-white . 15) (yellow . 14) + (light-magenta . 13) (light-red . 12) + (light-cyan . 11) (light-green . 10) (light-blue . 9) + (gray . 8) (white . 7) (brown . 6) (magenta . 5) + (red . 4) (cyan . 3) (green . 2) (blue . 1) (BLACK . 0))) + (attrs-ti '((ALTCHAR . 128) (BLINK . 64) + (UNDERLINE . 32) (REVERSE . 16) (NODSP . -8) + (WHITE . 7) (YELLOW . 6) (cyan . 5) (GREEN . 4) + (PURPLE . 3) (RED . 2) (blue . 1) (BLACK . 0))) + (default-attrs-ibm 15) + (default-attrs-ti 15) + (prime-ibm 0) + (prime-ti 8)) + (lambda x + (let ((work-fn + (LAMBDA (attrs default acc) + (COND + ((NULL? X) + (SET! ACC default)) + ((NUMBER? (CAR X)) + (SET! ACC (CAR X))) + (else + (MAPC + (LAMBDA (x) + (let ((attr-value (assq x attrs))) + (and attr-value + (set! acc (+ acc (cdr attr-value)))))) + x))) + (and (=? pcs-machine-type 1) ;keep text enabled in TI mode + (=? acc prime-ti) + (set! acc default)) + acc))) + (case (car x) + (ti + (set! x (cdr x)) + (work-fn attrs-ti default-attrs-ti prime-ti)) + (ibm + (set! x (cdr x)) + (work-fn attrs-ibm default-attrs-ibm prime-ibm)) + (else + (if (=? pcs-machine-type 1) + (work-fn attrs-ti default-attrs-ti prime-ti) + (work-fn attrs-ibm default-attrs-ibm prime-ibm)))))))) + \ No newline at end of file diff --git a/sources/stl.s b/sources/stl.s new file mode 100644 index 0000000..85b8915 --- /dev/null +++ b/sources/stl.s @@ -0,0 +1,120 @@ +;;; PC Scheme toplevel +;;; Copyright 1987 (c) Texas Instruments + + +;;; The following is the PC Scheme standard toplevel function. +;;; This definition of it is suitable for loading via an .INI file. + + +; When this is loaded, the fluid variable SCHEME-TOP-LEVEL is set +; to the outer lambda expression. When PC Scheme finishes loading +; the .INI file, it does an internal SCHEME-RESET. That activates +; this function, and also snapshots the VM state; further SCHEME-RESET's +; will always restore the state of PC Scheme to this initial snapshot. +; The outer lambda expression's body calls the local function ==SCHEME-RESET==. +; The fluid variables INPUT-PORT and OUTPUT-PORT are initialized to the +; values of STANDARD-INPUT and STANDARD-OUTPUT, which in turn are always +; bound to 'CONSOLE unless you explicitly set them otherwise. +; The history list is set to nil. The debug-mode flag is examined and +; an appropriate message is output. Then comes the most interesting +; part--a continuation snapshots the context at this point of execution +; in the function and is assigned to the variable ==RESET==. Then the +; fluid variable SCHEME-TOP-LEVEL is rebound to this continuation. +; Henceforth, further RESET's will start execution of the toplevel function +; at this point, skipping the above initializations. A GC is done before +; executing the local function MORE. + +; MORE is the read-eval-print section of the toplevel. The prompt is +; displayed. Input is read, consed onto the history list, and evaluated, +; with the result printed with WRITE and also consed onto the history list. +; In the midst of this, the local variable NEXT is bound to SCHEME-TOP-LEVEL's +; value. It is possible that the evaluation of the input form might have +; changed SCHEME-TOP-LEVEL. If NEXT is still bound to ==RESET==, the +; continuation derived above, then the current toplevel function is still +; in control and we loop back to MORE, skipping the initializations that +; RESET or SCHEME-RESET would perform. Otherwise, a new toplevel is +; indicated, and we call it. + +; To summarize, the system's toplevel function has 3 entry points. +; First, SCHEME-RESET restarts the outer lambda expression, +; which invokes the local function ==SCHEME-RESET==, and that +; resets the history list and input and output ports, among other things. +; Second, RESET restarts the continuation marked by the CALL/CC, +; and a GC occurs. Finally, the local function MORE takes care +; of the read-eval-print loop. Once entered, MORE is never exited +; unless a RESET or SCHEME-RESET are executed to redo their appropriate +; levels of initialization. + + +;;; define standard toplevel loop and support functions + + +(set! (fluid scheme-top-level) + (lambda () ; outer lambda + (letrec + ((==reset== '()) + (==scheme-reset== ; here for SCHEME-RESET + (lambda () + (set! (fluid input-port) standard-input) + (set! (fluid output-port) standard-output) + (putprop '%PCS-STL-HISTORY (list '()) %pcs-stl-history) + (newline) + (display "[PCS-DEBUG-MODE is ") + (display (if pcs-debug-mode "ON]" "OFF]")) + (newline) + (call/cc + (lambda (k) + (set! ==reset== (lambda () (k '()))) + (set! (fluid scheme-top-level) + ==reset==))) + ; here for RESET + (gc) + (more))) + (more ; read-eval-print loop + (lambda () + (fresh-line) + (display "[") + (display (length (getprop '%PCS-STL-HISTORY %pcs-stl-history))) + (display "]> ") + (let ((problem (read))) + (flush-input) + (if (eof-object? problem) + (display "[End of file read by SCHEME-TOP-LEVEL]") + (begin + (putprop '%PCS-STL-HISTORY + (cons (list problem) + (getprop '%PCS-STL-HISTORY + %pcs-stl-history)) + %pcs-stl-history) + (let* ((answer (eval problem)) + (next (fluid scheme-top-level))) + (when (not (eq? answer *the-non-printing-object*)) + (write answer)) + (putprop '%PCS-STL-HISTORY + (cons (cons problem answer) + (cdr (getprop '%PCS-STL-HISTORY + %pcs-stl-history))) + %pcs-stl-history) + (if (eq? next ==reset==) + (more) + (next))))))))) ;end of letrec vars + (==scheme-reset==) ;letrec body + ))) + + ;;; %C accesses the nth user command + ;;; %D accesses the result of the nth user command + +(define %c ; %C + (lambda (n) + (let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history))) + (and (positive? n) + (< n (length history)) + (car (list-ref (reverse history) n)))))) + +(define %d ; %D + (lambda (n) + (let ((history (getprop '%PCS-STL-HISTORY %pcs-stl-history))) + (and (positive? n) + (< n (length history)) + (cdr (list-ref (reverse history) n)))))) + \ No newline at end of file diff --git a/sources/tutframe.s b/sources/tutframe.s new file mode 100644 index 0000000..b92ef9c --- /dev/null +++ b/sources/tutframe.s @@ -0,0 +1,381 @@ +;;; Tutorial Engine tutorial +;;; Copyright 1987 (c) Texas Instruments + + +;;; This is the tutorial text to the Tutorial Engine tutorial. + + +; To run this tutorial, first compile and fasl the file "tutoreng.s". +; Then do the following: +; +; (load "tutoreng.fsl") ;load the Tutorial Engine program +; (load "tutframe.s") ;load this tutorial +; (start-tutorial) ;start it + +; If you prefer a paper tutorial to an online one, you can do the following: +; (set! *auto-tutorial?* #t) +; (transcript-on "") +; (start-tutorial) +; ; the tutorial runs by itself; when it finishes: +; (transcript-off) +; The tutorial has been captured on the transcript file. +; *Auto-tutorial?* does not create output suitable for a book, but +; the results are readable. + +; If you're wondering why the SCOOPS tutorial isn't run the +; same way, it could have been, but it is packaged differently. +; The Tutorial Engine program, tutorial text, and graphics demo +; were combined together in one fasl file. Contrary to a statement +; in one of the manuals, this is easy to do; just use DOS COPY to +; concatenate the fasl files together, but be sure to specify +; the /b (binary) option to avoid early truncation. + + +(define extensions + (lambda (word window) + (let ((c (string-ref word 0))) + (case c + (#\/ (window-set-attribute! window 'text-attributes (attr 'yellow)) + (display (substring word 1 (string-length word)))) + (#\\ (window-set-attribute! window 'text-attributes (attr)) + (display (substring word 1 (string-length word)))) + (else (display word window)))))) + + + +;;; the tutorial's frames ---------------------------------------- + +(set! *tutorial* + (make-tutorial + 'name "The Tutorial Engine" + 'writeln-extensions extensions)) + +(frame + () + ("The /Tutorial Engine \\is a program that" + "implements a simple model of tutorial interaction." + "This permits the interaction to be embodied in the program itself," + "but the tutorial text is separate from the program, and many different" + "tutorial texts can be used with the program.") + () + ("There are added advantages to the tutorial writer." + "Text is automatically formatted so you don't have to," + "and examples are executed directly so you don't have to" + "capture input and output values and format them yourself." + "The current presentation format is admittedly biased towards" + "displaying Scheme code.") + () + "Introduction") + +(frame + () + ("The model is one familiar to most people: the slide show." + "A /tutorial \\(slide show) consists of a series of /frames \\(slides)." + "Normally, you progress through the frames in a forward direction," + "but you can skip around." + "A frame concentrates on one topic, or /example, \\with" + "explanatory text surrounding the example.") + () + ("Unlike a slide show, you interact with the tutorial." + "Therefore, various kinds of assistance" + "are available. A /help \\window lists the single-keystroke commands and" + "what they do. The /table of contents \\displays the topics covered by" + "the tutorial, gives the frame number at which they start," + "and permits you to move around randomly in the tutorial." + "The /index \\displays terms and phrases in alphabetical order," + "lists their frame numbers," + "and also allows you to skip around in the tutorial.") + () + () + ("tutorial" "example" "frame" "help" "table of contents" "index")) + +(frame + initial + ("Your view of a frame, as a user, is one screen containing" + "text introducing the topic or example of the frame,") + (:eval (display "the topic itself, set off from the surrounding text") + :fresh-line + :eval (display "and highlighted in green,")) + ("and text afterwards explaining the example.") + () + "Frames") + +(frame + () + ("From the Tutorial Engine's point of view," + "a frame is conceptually a Scheme structure but is implemented as a list." + "Macros are used to hide this implementation from the rest of the program." + "The frame format looks like this:") + (:eval (display '(frame name before-text example after-text + dependencies tc-entry index-entries))) + ("The FRAME keyword starts each frame. 'name' is an optional symbol" + "that can be referenced by the dependency lists of other frames." + "'before-text' and 'after-text' are lists of strings of text." + "'tc-entry' consists of a string of text to be placed in the" + "tutorial's table of contents." + "'index-entries' is a list of strings; each string should be a word" + "or short phrase that would be appropriate to put into an index." + "Subsequent frames discuss the 'example' and 'dependencies' entries.") + () + () + ("frame")) + +(frame + () + ("The 'example' field is a list" + "of /keyword \\or /keyword/value pairs \\representing" + "Scheme expressions to be evaluated and displayed." + "A keyword begins with a colon." + "For example, the" + "following description in the first line below" + "generates the output in the second line:") + (:eval (display '(:data (+ 3 5) :data-eval :pp-data :yields :pp-evaled-data)) + :eval (begin (fresh-line) (newline)) + :data (+ 3 5) :data-eval :pp-data :yields :pp-evaled-data) + ("/:DATA \\records the text of the data. /:DATA-EVAL \\evaluates the data." + "/:PP-DATA \\pretty-prints the data itself while //:PP-EVALED-DATA" + "\\pretty-prints its result. /:YIELDS \\prints an arrow." + "/:EVAL \\(not shown above) evaluates an arbitrary Scheme expression," + "and there are other keywords too." + "Note that with this feature, examples are active items and not" + "just passive pieces of text--the examples are actually executed" + "during the running of a tutorial.") + () + () + ("example")) + +(frame + () + ("The last field of a frame to be discussed are the 'dependencies.'" + "This is a list of frame names on which this frame depends." + "Since the examples are actually executed, and since the user" + "can go to any frame at will, any set-up for the examples" + "in that frame would likely be bypassed without this feature.") + () + ("This approach, while flexible, has its limitations." + "The primary one is speed. Straight text examples take more work" + "to generate, but text displays are fast. Because dependencies" + "have to be evaluated, if there are many of them, or if they involve" + "time-consuming computations, it may take awhile to display the result." + "Also, it is tricky getting their ordering correct.") + () + () + ("dependencies")) + +(frame + () + ("A tutorial is not complete without two more things." + "The first is to define a /print function \\that prints individual words," + "possibly changing screen attributes (color, reverse video, etc.)" + "along the way. The function takes 2 arguments: a word, which is" + "a string, and a window in which to print the string." + "Examining the source of this tutorial text should make its" + "structure clear.") + () + ("The important thing to note is that this function is /not \\part" + "of the Tutorial Engine but belongs to the tutorial itself." + "Different tutorials can use different printing functions," + "giving some variety in how frames are displayed," + "while still working within the model used by the Tutorial Engine.") + () + "Tutorial Structure" + ("print function")) + +(frame + () + ("The second is to create a /tutorial structure \\and assign" + "it to *TUTORIAL*." + "Unlike a frame, this is a true Scheme structure, and it has these fields:") + (:eval (display '(name write-extensions frame-list visited-list + frame-number name-list tc index))) + ("You should initialize 2 fields: 'name', to a string with the name" + "of the tutorial, and 'write-extensions', to the print function" + "discussed in the previous frame.") + () + () + ("tutorial structure")) + +(frame + () + ("The other fields are used during the running of a tutorial." + "When a tutorial is read from disk, the frames are consed into a list." + "Then the list is converted to an array and stored in 'frame-list'." + "The 'frame-number' is the number of the frame currently visible." + "When a frame is displayed, its position in 'visited-list'" + "(really an array again) is marked true." + "When you skip around in a tutorial, the visited list is used" + "to determine if the frames on which this one depends" + "have all been executed.") + () + ("The 'name-list' is a list of pairs of individual frame names and" + "corresponding frame numbers and is for debug purposes." + "The 'tc' and 'index' are the values used in the table of contents" + "and index, respectively. The former has the format:" + "((frame# tc-entry) ...) arranged by increasing frame number," + "and the latter has a format:" + "((index-entry frame# frame# ...)) sorted in alphabetical order." + "These are determined once, when a tutorial is started.")) + +(frame + () + ("The Tutorial Engine has two exported functions, /START-TUTORIAL" + "\\and /RESUME-TUTORIAL. \\A LETREC encloses the Tutorial Engine's" + "local functions. A brief summary of the local functions follows.") + () + () + () + "Description of the Tutorial Engine Program" + ("exported functions")) + +(frame + () + ("/START-TUTORIAL \\and /RESUME-TUTORIAL \\call /INIT-TUTORIAL." + "\\The banner screen is displayed by /BANNER \\if the tutorial hasn't" + "been run before in the current session." + "The routine /COLLECT-TC \\organizes the table of contents using" + "the TC fields of each frame," + "/COLLECT-INDEX \\works similarly using each frame's INDEX field," + "and /COLLECT-NAMES \\looks at each frame's NAME field." + "This last is for debugging and editing purposes." + "Part of the initialization includes saving two continuations:" + "/QUIT-K \\to exit the tutorial, and /USER-ERROR-HANDLER, \\which" + "gets assigned to the system hook *USER-ERROR-HANDLER*," + "to recover from errors.") + () + () + () + () + ("initialization")) + +(frame + () + ("/DO-TUTORIAL \\implements looping over each tutorial frame." + "/FRAME-1 \\executes one frame of the tutorial." + "/DISPLAY-TITLE-WINDOW \\displays the frame number and any" + "table-of-contents title." + "Displaying the 3 zones of before-text, example, and after-text" + "is the job of the routines /TEXT-ZONE \\and /CALC-ZONE. \\") + () + ("/CONTINUE \\handles all single-key input. It calls" + "/NEXT-FRAME \\and /PREVIOUS-FRAME \\to move between frames," + "/HELP \\to display help information about single-key inputs," + "/TABLE-OF-CONTENTS \\to handle table-of-contents processing," + "ditto /INDEX \\for index processing, /QUIT \\to exit the tutorial" + "by invoking the QUIT-K continuation, and /ALERT \\to display an" + "error message in a pop-up window.") + () + () + ("main loop" "keystroke handling")) + +(frame + () + ("/TEXT-ZONE \\is passed the list of strings to print." + "/DEMO-WRITELN \\is called in turn with each string." + "It breaks the string into individual words and calls" + "the printing hook function of *TUTORIAL* to print each" + "word as it sees fit. Filling the line is done automatically by Scheme." + "The text zone widths are shrunk somewhat for esthetic reasons," + "and also the somewhat limited space forces the tutorial writer" + "to be concise.") + () + () + () + () + ("zone handling")) + +(frame + () + ("/EXECUTE-FRAME-ITEM \\parses and executes the example expressions" + "in a frame. If the expressions depend on other expressions being" + "executed first, it recursively calls itself to handle those frames first" + "and puts up a /BUSY-WINDOW \\meanwhile. /FRAME-ITEM-PARSER \\is the" + "workhorse function.") + () + () + () + () + ("zone handling" "parsing")) + +(frame + () + ("/EDIT \\permits limited editing of a frame while a tutorial is running," + "assuming the global variable /*DEBUG-TUTORIAL* \\has been properly" + "activated. The edit mode permits using Edwin to edit a frame and" + "then replacing the current frame with the edited one in order to" + "check on the appearance of the edited frame; this avoids having to" + "recompile the entire Edwin buffer just to test a new frame." + "Inserting or deleting frames is not implemented.") + () + ("Evaluating a frame's example can be turned on and off from the edit" + "mode. Evaluation errors automatically turn off frame evaluation so" + "that the frame can be examined and edited. You can also go into" + "a new system toplevel temporarily to test-evaluate examples.") + () + () + ("edit mode")) + +(frame + () + ("Some of the LETREC variables are used for data. The tutorial's" + "/START-FRAME \\and /END-FRAME \\are part of the Tutorial Engine itself" + "and not in the tutorial text. /EVAL? \\controls executing a frame's" + "example and is used in edit mode.") + () + () + () + () + ("data values")) + +(frame + () + ("The Tutorial Engine is a complete Scheme program which demonstrates" + "several useful Scheme programming techniques. Among these are using" + "LETREC to /define local variables and functions \\which are hidden from" + "the outside unless they are explicitly exported, like START-TUTORIAL," + "RESUME-TUTORIAL, and the rebinding of *USER-ERROR-HANDLER*." + "A Scheme /structure \\is used to represent the tutorial" + "and /macros \\hide the representation of a frame." + "Macros are also used to extend the Scheme language, such as in" + "WITH-POPUP-WINDOW, which defines a Common-Lisp-like form that" + "uses keywords as part of its syntax.") + () + () + () + "Scheme Techniques") + +(frame + () + ("/Continuations \\are used to implement exit and recovery points." + "A named LET implements /looping \\in the local function CONTINUE." + "/Window manipulations \\are demonstrated in many different places." + "For example, ALERT pops up a small error message window, the BUSY-WINDOW" + "is borderless, and TABLE-OF-CONTENTS and INDEX popup windows" + "take over the entire screen." + "FRAME-ITEM-PARSER shows how an /interpreter for a new language \\is" + "build on top of Scheme through the use of EVAL." + "Finally, with /lexical scoping \\the PRINT routine" + "is redefined without affecting the system's PRINT routine.")) + +(frame + () + ("A couple of tricks specific to PC Scheme are also demonstrated." + "One is the creation of a /new toplevel." + "\\The other is temporarily /redefining a frame's PCS*MACRO property \\so" + "that a frame recompiled from Edwin can be redisplayed by the" + "Tutorial Engine without requiring the recompilation of the entire" + "tutorial text, which takes considerably longer." + "Both of these occur inside EDIT.")) + +(frame + () + ("This concludes our discussion of the Tutorial Engine." + "The conceptual model that it implements of tutorial interaction is simple" + "and can no doubt be expanded in many ways;" + "maybe you will do so. At the least, you should find this complete example" + "helpful in organizing your own Scheme programming.") + (:data "Happy Scheming!!" :pp-data) + () + () + "Conclusion") + + \ No newline at end of file diff --git a/sources/tutoreng.s b/sources/tutoreng.s new file mode 100644 index 0000000..6127417 --- /dev/null +++ b/sources/tutoreng.s @@ -0,0 +1,763 @@ +;;; ============================================= +;;; The Tutorial Engine +;;; +;;; Bob Beal +;;; +;;; Copyright 1986,1987 (c) Texas Instruments +;;; ============================================= + + +;;; Auxiliary macros ========================= + +;; these might be useful anywhere + +;; form: (push value var) +;; push "value" onto list stored at "var" +;; not a generalized-variable push +(macro push + (lambda (e) + (let ((value (cadr e)) + (var (caddr e))) + `(set! ,var (cons ,value ,var))))) + +;; form: (in-bounds? low value high) +;; tests "low" <= "value" < "high" +(macro in-bounds? + (lambda (e) + (let ((lo (cadr e)) + (x (caddr e)) + (hi (cadddr e))) + `(and (<=? ,lo ,x) (number ,e))))) + +;; form: (set-frame-visited! frame true-or-false) +(macro set-frame-visited! + (lambda (e) + (let ((e (cadr e)) (value (caddr e))) + `(vector-set! (tutorial-visited-list *tutorial*) + (frame->number ,e) + ,value)))) + +;; form: (frame->number frame) +;; given a frame, return its number +(macro frame->number + (lambda (e) + (let ((e (cadr e))) + `(cdr (assq (frame-name ,e) (tutorial-name-list *tutorial*)))))) + +;; form: (name->frame name) +;; given a frame name, return its frame +(macro name->frame + (lambda (e) + (let ((name (cadr e))) + `(nth-frame (cdr (assq ,name (tutorial-name-list *tutorial*))))))) + +;; for the executing tutorial ------------------------- + +;; form: (unstarted-tutorial?) +;; has this tutorial been run since loading? +(macro unstarted-tutorial? + (lambda (e) + '(not (vector? (tutorial-frame-list *tutorial*))))) + +;; form: (tutorial-length) +;; returns the number of frames in the tutorial +(macro tutorial-length + (lambda (e) + '(vector-length (tutorial-frame-list *tutorial*)))) + +;; form: (frame-list) +;; returns the tutorial's frame-list +(macro frame-list + (lambda (e) + '(tutorial-frame-list *tutorial*))) + +;; form: (frame-number) +;; returns the frame-number of the current frame +(macro frame-number + (lambda (e) + '(tutorial-frame-number *tutorial*))) + +;; form: (current-frame) +;; returns the current frame +(macro current-frame + (lambda (e) + '(vector-ref (tutorial-frame-list *tutorial*) + (tutorial-frame-number *tutorial*)))) + +;; form: (demo-writeln-extensions) +;; returns the function that handles text in a text zone +(macro demo-writeln-extensions + (lambda (e) + `(tutorial-writeln-extensions *tutorial*))) + +;; this macro defines one "frame" ------------------------- + +(macro frame + (lambda (e) + `(push ',e (tutorial-frame-list *tutorial*)))) + +(macro frame-during-edit + (lambda (e) + `(set! *frame* ',e))) + +;; for popup windows (menus, help screens) ------------------------- + +;; form: (with-popup-window dummy-window-var +;; TITLE string +;; TEXT-ATTRIBUTES attributes +;; BORDER-ATTRIBUTES attributes +;; POSITION (row . column) +;; SIZE (rows . columns) +;; &BODY &body) +;; The keywords aren't evaluated but the associated values are. +(macro with-popup-window + (lambda (e) + (let ((w (cadr e)) + (title (cadr (memq 'title e))) + (text-attributes (cadr (memq 'text-attributes e))) + (border-attributes (cadr (memq 'border-attributes e))) + (position (cadr (memq 'position e))) + (size (cadr (memq 'size e))) + (body (cdr (memq '&body e)))) + `(let ((,w (make-window ,title #!true))) + ,(when text-attributes + `(window-set-attribute! ,w 'text-attributes ,text-attributes)) + ,(when border-attributes + `(window-set-attribute! ,w 'border-attributes ,border-attributes)) + ,(when position + `(window-set-position! ,w (car ,position) (cdr ,position))) + ,(when size + `(window-set-size! ,w (car ,size) (cdr ,size))) + (window-popup ,w) + (begin0 + (begin ,@body) + (window-popup-delete ,w)))))) + +;; other ------------------------- + +;; form: (center-at msg) +;; returns the column at which cursor must be positioned to +;; center msg on console window +(macro center-at + (lambda (e) + (let ((msg (cadr e))) + `(- 40 (floor (/ (string-length ,msg) 2)))))) + +;;; Auxiliary functions ========================= + +(define ATTR + (let ((attrs-ibm '((blink . 128) (bkg-white . 112) + (bkg-brown . 96) (bkg-magenta . 80) (bkg-cyan . 48) + (bkg-red . 64) (bkg-green . 32) (bkg-blue . 16) + (light-white . 15) + (yellow . 14) (light-magenta . 13) (light-red . 12) + (light-cyan . 11) (light-green . 10) (light-blue . 9) + (gray . 8) (white . 7) (brown . 6) (magenta . 5) + (red . 4) (cyan . 3) (green . 2) (blue . 1) (BLACK . 0))) + (attrs-ti '((ALTCHAR . 128) (BLINK . 64) + (UNDERLINE . 32) (REVERSE . 16) (NODSP . -8) + (WHITE . 7) (YELLOW . 6) (cyan . 5) (GREEN . 4) + (PURPLE . 3) (RED . 2) (blue . 1) (BLACK . 0))) + (default-attrs-ibm 15) + (default-attrs-ti 15) + (prime-ibm 0) + (prime-ti 8)) + (lambda x + (let ((work-fn + (LAMBDA (attrs default acc) + (COND + ((NULL? X) + (SET! ACC default)) + ((NUMBER? (CAR X)) + (SET! ACC (CAR X))) + (else + (MAPC + (LAMBDA (X) + (AND (ASSOC X ATTRS) + (SET! ACC (+ ACC (CDR (ASSOC X ATTRS)))))) X))) + (and (=? pcs-machine-type 1) ;keep text enabled in TI mode + (=? acc prime-ti) + (set! acc default)) + acc))) + (if (=? pcs-machine-type 1) + (work-fn attrs-ti default-attrs-ti prime-ti) + (work-fn attrs-ibm default-attrs-ibm prime-ibm)))))) + +(define demo-writeln + (lambda (x w) ;x=string of >=1 words, w=window + (mapc (lambda (word) + (cond (((demo-writeln-extensions) word w)) + (else (display word w)))) + (let loop ((word-list nil) (s x)) + (let ((n (substring-find-next-char-in-set s 0 (string-length s) " "))) + (cond (n (loop (cons (substring s 0 (1+ n)) word-list) + (substring s (1+ n) (string-length s)))) + (else (reverse (cons (string-append s " ") word-list))))))))) + +;; a "filler" function +(define (do-nothing . x) nil) + +;(define visited +; (lambda () +; (vector->list (tutorial-visited-list *tutorial*)))) + +;;; Advertised public interface ========================= + +;; Global variables ------------------------- + +(define *data-item*) +(define *evaled-data-item*) +(define *tutorial*) +(define *auto-tutorial?* nil) +(define *debug-tutorial* nil) ;not advertised +(define *frame* nil) ; " + +;; Exported functions ------------------------- + +(define start-tutorial) +(define resume-tutorial) + +;;; the tutorial "engine" ========================= + +(letrec + ((alert + (lambda (msg) + (with-popup-window w + title "" + size `(1 . ,(string-length msg)) + position `(5 . ,(center-at msg)) + border-attributes (attr 'red) + text-attributes (if (=? pcs-machine-type 1) + (attr 'red 'reverse) + (attr 'black 'bkg-red)) + &body + (beep) + (display msg w) + (read-char)))) + (banner + (lambda () + (window-clear 'console) + (with-popup-window w + title "" + size '(22 . 78) + position '(1 . 1) + &body + (let ((clear-msg "Press any key to continue.") + (banner + `("Texas Instruments" + "proudly presents:" + "" + "A PC Scheme Tutorial" + "on" + ,@(cond ((string? (tutorial-name *tutorial*)) + (list (tutorial-name *tutorial*))) + ((pair? (tutorial-name *tutorial*)) + (tutorial-name *tutorial*)) + (else + (list "The Reliance of Programming on Thaumaturgy")))))) + (window-set-cursor! w 3 1) + (for-each (lambda (s) + (window-set-cursor! + w + (car (window-get-cursor w)) + (center-at s)) + (print s w) + (newline w)) + banner) + (window-set-cursor! + w + 21 + (center-at clear-msg)) + (display clear-msg w) + (tutorial-read-char))))) + (beep + (lambda () + (display (integer->char 7)))) + (busy-window + (let ((w (make-window nil nil))) + (window-set-size! w 1 20) + (window-set-attribute! w 'text-attributes (attr 'green 'blink)) + w)) + (calc-zone + (lambda (e) + (window-set-attribute! 'console 'text-attributes (attr 'green)) + (clear-rest-of-visited-list (frame->number e)) ;force reanalysis of environment + (execute-frame-item e #!true eval?) + (fresh-line) + (newline))) + (clear-rest-of-visited-list + (lambda (n) + (cond ((>=? n (tutorial-length))) + (else + (vector-set! (tutorial-visited-list *tutorial*) n #!false) + (clear-rest-of-visited-list (1+ n)))))) + (clear-visited-list + (lambda () + (vector-fill! (tutorial-visited-list *tutorial*) nil))) + (collect-index + (lambda () + (set! (tutorial-index *tutorial*) + (sort! + (let loop ((n 0) (acc nil)) + (cond ((>=? n (tutorial-length)) acc) + (else + (for-each (lambda (string) + (let ((index-item (assoc string acc))) + (cond (index-item + (append! index-item (list n))) + (else + (push (list string n) acc))))) + (frame-index-entry (nth-frame n))) + (loop (1+ n) acc)))) + (lambda (x y) + (string-ci=? n (tutorial-length)) + (set! (tutorial-name-list *tutorial*) acc)) + ((frame-name (nth-frame n)) + (loop (1+ n) (cons (cons (frame-name (nth-frame n)) + n) + acc))) + (else ;give it a name and try again + (set-frame-name! (nth-frame n) (gensym)) + (loop n acc)))))) + (collect-tc + (lambda () + (set! (tutorial-tc *tutorial*) + (sort! + (let loop ((n 0) (acc nil)) + (cond ((>=? n (tutorial-length)) + acc) + ((frame-tc-entry (nth-frame n)) + (loop (1+ n) + (cons (list n (frame-tc-entry (nth-frame n))) acc))) + (else + (loop (1+ n) acc)))))) + (when (>=? (length (tutorial-tc *tutorial*)) 21) + (error "Only 20 entries are allowed in the tutorial table of contents.")))) + (continue + (lambda () + (let ((bad-key-msg "Invalid key pressed. \"?\" provides help.")) + (fresh-line) + (display (integer->char 2)) + (let again ((ch (tutorial-read-char))) + (case ch + (#\? (again (help))) + (#\backspace nil) + ((#\e #\E) (again (if *debug-tutorial* + (edit) + (alert bad-key-msg)))) + ((#\i #\I) (index)) + ((#\p #\P) (again (previous-frame))) + ((#\q #\Q) (quit)) + ((#\return #\space #\n #\N) (again (next-frame))) + ((#\t #\T) (table-of-contents)) +; (nil nil) ;this doesn't work for some reason + (#!true nil) ;so use this instead + (else (again (alert bad-key-msg)))))))) + (display-title-window + (let ((blanks (make-string 15 #\space))) + (lambda () + (window-clear title-window) + (display blanks title-window) + (print (frame-number) title-window) + (print blanks title-window) + (when (frame-tc-entry (current-frame)) + (demo-writeln (frame-tc-entry (current-frame)) title-window) + (fresh-line title-window) + (newline title-window))))) + (do-tutorial + (named-lambda (loop) + (frame-1 (current-frame)) + (loop))) + (edit + (lambda () + (let ((prev-defn (getprop 'frame 'pcs*macro))) + (putprop 'frame (getprop 'frame-during-edit 'pcs*macro) 'pcs*macro) + (begin0 + (with-popup-window + w + title "Edit menu" + size '(12 . 34) + position '(3 . 45) + &body + (print (assq (frame-name (current-frame)) (tutorial-name-list *tutorial*)) w) + (print (string-append "Frame evaluation is: " (if eval? "ON" "OFF")) w) + (print "" w) + (print "E - call Edwin" w) + (print "R - replace" w) + (print "T - new toplevel" w) + (print "V - toggle frame evaluation" w) + (print "and all standard keys" w) + (print "" w) + (let again ((ch (read-char))) + (case ch + ((#\e #\E) + (edwin) + (again (read-char))) + ((#\r #\R) + (cond ((frame? *frame*) + (set-frame-name! *frame* (frame-name (current-frame))) + (set! (current-frame) *frame*) + #!true) + (else + (alert "Frame has bad format. Replace not done.")))) + ((#\t #\T) ;will this work? YES!! + (beep) + (print "((fluid q)) quits new toplevel" w) + (let ((prev-history (getprop '%pcs-stl-history %pcs-stl-history))) + (call/cc + (lambda (k) + (fluid-let ((scheme-top-level nil) + (q (lambda () (k 'end-top-level)))) +; (set! pcs-gc-reset "((fluid q)) quits new toplevel") + (reset-scheme-top-level) + (reset)))) + (set! pcs-gc-reset nil) + (putprop '%pcs-stl-history prev-history %pcs-stl-history) + #!true)) + ((#\v #\V) + (set! eval? (not eval?)) + #\E) ;force redisplay of edit menu + (else ch)))) + (putprop 'frame prev-defn 'pcs*macro))))) + (end-frame + '(frame + () + ("You have reached the end of the tutorial." + "Please press \"Q\" to exit."))) + (eval? #!true) ;var used in edit mode + (execute-frame-item + (lambda (e print? eval?) + (cond ((eq? (frame-visited? e) #!true)) + ((null? (frame-dependencies e)) + (frame-item-parser (frame-item e) print? eval?) + (set-frame-visited! e #!true)) + (else + (when print? + (window-set-position! busy-window + (car (window-get-cursor 'console)) + 0) + (window-popup busy-window) ;popdown when output occurs + (display "Evaluating..." busy-window)) + (for-each (lambda (e) + (set! e (name->frame e)) + (execute-frame-item e #!false eval?)) + (frame-dependencies e)) +; (when print? +; (window-popup-delete busy-window)) + (frame-item-parser (frame-item e) print? eval?) + (set-frame-visited! e #!true))))) + (frame-1 + (lambda (e) + (window-clear 'console) + (display-title-window) + (when (frame-lines-before e) (text-zone (frame-lines-before e))) + (when (frame-item e) (calc-zone e)) + (when (frame-lines-after e) (text-zone (frame-lines-after e))) + (continue))) + (frame-item-parser + (lambda (cmds print? eval?) + (let loop ((cmds cmds)) + (cond ((null? cmds)) + (else + (case (car cmds) + (:data (set! *data-item* (cadr cmds)) + (set! cmds (cdr cmds))) +; (:read (set! *data-item* (read data-port))) + (:data-eval + (when eval? (set! *evaled-data-item* (eval *data-item*)))) + (:eval + (when eval? (eval (cadr cmds))) + (set! cmds (cdr cmds))) +; (:skip (read data-port)) + ((:pp-data :pp-evaled-data :yields :fresh-line :output) + (when print? + (window-popup-delete busy-window) ;popdown busy msg + (case (car cmds) + (:output (when eval? (eval (cadr cmds))) + (set! cmds (cdr cmds))) + (:pp-data (pp *data-item*)) + (:pp-evaled-data (pp *evaled-data-item*)) + (:yields (display " ---> ")) + (:fresh-line (fresh-line))))) + (else nil)) + (loop (cdr cmds))))))) + (help + (lambda () + (with-popup-window w + title "Help menu" + size '(12 . 34) + position '(3 . 45) + &body + (print "? - This menu" w) + (print "BACKSPACE - refresh screen" w) + (when *debug-tutorial* + (print "E - edit tutorial" w)) + (print "I - index" w) + (print "N, RETURN, SPACE - next frame" w) + (print "P - previous frame" w) + (print "T - table of contents" w) + (print "Q - quit tutorial" w) + (read-char)))) + (index + (lambda () + (let ((prompt-msg "Please type a frame number, nil, U, or D, then RETURN: ")) + (with-popup-window + w + title "Index" + size '(22 . 78) + position '(1 . 1) + &body + (let show-one-page ((n 0)) + (window-clear w) + (let vloop ((start (list-tail (tutorial-index *tutorial*) n)) + (end (list-tail (tutorial-index *tutorial*) (+ n 20)))) + (cond ((eq? start end)) + (else + (display " " w) + (display (caar start) w) + (let hloop ((tab-to 27) + (frame-no-list (cdar start))) + (cond ((null? frame-no-list)) + (else + (tab (current-column w) tab-to 4 w) + (display (car frame-no-list) w) + (display " " w) + (hloop (+ tab-to 4) (cdr frame-no-list))))) + (newline w) + (vloop (cdr start) end)))) + (window-set-cursor! 'console 22 (center-at prompt-msg)) + (display prompt-msg) + (let ((frame-no (read))) + (flush-input) + (cond ((and (number? frame-no) + (in-bounds? 0 frame-no (tutorial-length))) + (clear-visited-list) + (set! (frame-number) frame-no)) + ((eq? frame-no 'U) + (show-one-page (if (=? (+ n 20) (length (tutorial-index *tutorial*))) + n + (+ n 20)))) + ((and *debug-tutorial* + (assq frame-no (tutorial-name-list *tutorial*))) + (clear-visited-list) + (set! (frame-number) (cdr (assq frame-no (tutorial-name-list *tutorial*)))))) + #!true)))))) + (init-tutorial + (lambda (tutorial resume) + (when (not (equal? *debug-tutorial* '(#\?))) ;make it harder to enter debug mode + (set! *debug-tutorial* nil)) + (when tutorial + (set! *tutorial* tutorial)) + (when (not (tutorial? *tutorial*)) + (alert "There is no tutorial available.") + (quit)) + (when (and (unstarted-tutorial?) + resume) + (alert "You cannot resume an unstarted tutorial. Use (START-TUTORIAL).") + (quit)) + (when (unstarted-tutorial?) + (set! (frame-list) + (list->vector (cons start-frame + (reverse! (cons end-frame + (frame-list)))))) + (set! (tutorial-visited-list *tutorial*) + (make-vector (vector-length (frame-list)))) + (set! (frame-number) 0) + (set! eval? #!true) + (collect-names) + (collect-tc) + (collect-index)) + (begin ;make sure entire screen gets erased + (window-set-position! 'console 0 0) + (window-set-size! 'console 24 80) ;leave status line + (window-set-attribute! 'console 'text-attributes (attr)) + (window-clear 'console)) + (when (not resume) + (banner) + (set! (frame-number) 0) + (clear-visited-list)) + (call/cc + (lambda (k) + (set! quit-k (lambda () + (k nil))) + (call/cc (lambda (k) + (set! *user-error-handler* + (lambda x (user-error-handler k))))) + (do-tutorial))))) + (next-frame + (lambda () + (if (=? (frame-number) + (-1+ (tutorial-length))) + (if *auto-tutorial?* + #\q + (alert "You are on the last frame of the tutorial.")) + (begin (set! (frame-number) (1+ (frame-number))) + #!true)))) + (previous-frame + (lambda () + (if (zero? (frame-number)) + (alert "You are on the first frame of the tutorial.") + (begin (set! (frame-number) (-1+ (frame-number))) + #!true)))) + (print + (lambda (x w) + (display x w) + (newline w))) + (quit + (lambda () + (window-clear 'console) + (set! *user-error-handler* nil) + (quit-k))) + (quit-k reset) ;the quit continuation + ;reassigned by init-tutorial + (start-frame + '(frame + () + () + (:data "A PC Scheme Tutorial" :pp-data) + ("The \"?\" is the help key." + "It displays a menu which tells you" + "about other important keys which enable you" + "to move around in the tutorial or to leave it." + "\"?\" or other single-keystroke keys are available" + "anytime you see the \"happy-face\" character towards" + "the bottom of the screen." + "Occasionally, typed input is requested." + "Typed input is" + "usually a number, or the atom NIL, followed by" + "the RETURN key." + "If you exit the tutorial in the middle, you can" + "continue from where you left off" + "(in the same session)" + "by typing (RESUME-TUTORIAL)." + "An \"Evaluating...\" message may appear while the" + "tutorial establishes" + "the proper execution environment for the examples in that" + "frame.") + () + "Directions for running the tutorial" + ("directions for running tutorial"))) + (tab + (lambda (cur goal multiple w) + (cond (( "e:\\dir\\file" +; +(define filename-sans-extension + (lambda (file) + (let ((period (substring-find-next-char-in-set + file 0 (string-length file) "."))) + (if period + (substring file 0 period) + file)))) + +; +; EXTENSION-SANS-FILENAME - truncate any filename prefix leaving only +; ".xxx" +; +; Example: (extension-sans-filename "e:\\dir\\file.ext") -> ".ext" +; +(define extension-sans-filename + (lambda (file) + (let ((period (substring-find-next-char-in-set + file 0 (string-length file) "."))) + (if period + (substring file period (string-length file)) + "")))) + +; +; DIRECTORY-SANS-FILENAME - truncate the filename, including any preceding +; \, from a given pathname. +; +; Example: (directory-sans-filename "e:\\dir\\file.ext") -> "e:\\dir" +; +(define directory-sans-filename + (lambda (file) + (let ((slash (substring-find-previous-char-in-set + file 0 (string-length file) "\\"))) + (if slash + (substring file 0 slash) + (error "Directory name missing a preceding slash." file))))) + +; +; FILENAME-SANS-DIRECTORY - truncate everything to the left of the last +; \, including the \. +; +; Example: (filename-sans-directory "e:\\dir\\file.ext") -> "file.ext" +; +(define filename-sans-directory + (lambda (file) + (let ((slash (substring-find-previous-char-in-set + file 0 (string-length file) "\\"))) + (if slash + (substring file (add1 slash) (string-length file)) + file)))) + +; +; DRIVE-NAME - repeatedly do directory-sans-filename until have name +; with no \'s. +; +; Example: (drive-name "e:\\dir\\file.ext") -> "e:" +; +(define drive-name + (lambda (file) + (let ((slash (substring-find-previous-char-in-set + file 0 (string-length file) "\\"))) + (if slash + (drive-name (directory-sans-filename file)) + file)))) + +; +; COMPILE-FASL - This utility compiles a Scheme source file to a fasl file. +; Compile-fasl takes as input a source filename, and optional +; object and fasl filenames. If the object and/or fasl filenames +; are not specified, they will be created with .so and .fsl +; extensions respectively. +; +; Note the use of engines to display a period, "." , during compilation. +; +; Example: (compile-fasl "file.s") ;generates file.so and file.fsl +; + +(define compile-fasl + (lambda (src . x) + (let ((src-nx (filename-sans-extension src))) + (let ((obj (if (car x) (car x) (string-append src-nx ".so"))) + (fasl (if (cadr x) (cadr x) (string-append src-nx ".fsl"))) ) + (let loop ((engine (make-engine + (lambda () + (engine-return (compile-file src obj)))))) + (engine 150 + (lambda x nil) + (lambda (new-engine) + (display ".") + (loop new-engine)))) + (dos-call (string-append pcs-sysdir "\\make_fsl.exe") + (string-append obj " " fasl) + 4095 + 1))))) + +; +; COMPILE-ONLY - Compiles a given file without executing (unless form is a +; macro, alias, syntax, or define-integrable) the result. +; +; +; Compiles a given file without executing (unless form is a macro, alias, +; syntax, or define-integrable) the result. Also report compilation info. +; +; Example: (compile-only "file.s" "file.so") ;generates file.so +; +(define compile-only + (lambda (filename1 filename2) + (if (or (not (string? filename1)) + (not (string? filename2)) + (equal? filename1 filename2)) + (error "COMPILE-ONLY arguments must be distinct file names" + filename1 + filename2) + ;else + (letrec + ((i-port (open-input-file filename1)) + (o-port (open-output-file filename2)) + (loop + (lambda (form) + (if (eof-object? form) + (begin (close-input-port i-port) + (close-output-port o-port) + 'ok) + (begin (compile-to-file form) + (set! form '()) ; for GC + (loop (read i-port)))))) + (compile-to-file + (lambda (form) + (let ((cform (compile form))) + (when (and (pair? form) + (memq (car form) + '(MACRO SYNTAX ALIAS DEFINE-INTEGRABLE))) + (eval cform)) + (prin1 `(%execute (quote ,cform)) o-port) + (newline o-port))))) + + ; body of letrec + + (set-line-length! 74 o-port) + (loop (read i-port)))))) + +; +; PP-LOAD - Pretty prints each form of a source file to the console +; as it loads that file. +; +; Example: (pp-load "file.s") +; +(define (pp-load filename) + (define (load-form port) + (let ((form (read port)) + (result '())) + (if (not (eof-object? form)) + (begin + (newline) + (newline) + (pp form) + (set! result (eval (compile form))) + (if (not (eq? result *the-non-printing-object*)) + (begin (newline) (prin1 result))) + (load-form port))))) + (if (not (string? filename)) + (error "Argument to PP-LOAD not a filename" filename) + ;else + (begin + (load-form (open-input-file filename)) + (newline) + 'ok))) + +; +; TIMER - measures the execution speed of any arbitrary Scheme expression +; The argument EXPR is the expression to be timed while ITER is +; the number of times the expression should be invoked. TIMER also +; takes into account the time spent in the control loop of the +; TIMER function itself by subtracting this from the total time; +; therefore, the value returned accurately reflects the time actually +; spent executing the expression. +; +; Example: (timer (fib 15) 10) ;report the time taken to execute +; ;(fib 15) 10 times +; + +(syntax (timer expr iter) + (let* ((start-time (runtime)) + (end-time (do ((counter 1 (+ counter 1))) + ((> counter iter) (runtime)) + ((lambda () #F)))) + (go (begin (gc #T) (runtime))) + (stop (do ((counter 1 (+ counter 1))) + ((> counter iter) (runtime)) + ((lambda () expr)))) + (overhead (- end-time start-time)) + (net-time (- (- stop go) overhead))) + (/ net-time 100.0))) + \ No newline at end of file diff --git a/xli/exec.c b/xli/exec.c new file mode 100644 index 0000000..188d27e --- /dev/null +++ b/xli/exec.c @@ -0,0 +1,216 @@ +/* + This program demonstrates how regular DOS executable files can be + run from XLI and represents an alternative to DOS-CALL. It also + provides an example that uses string arguments and the "swap" + special service call to access them. + + User documentation is available under XLI\EXEC.DOC. EXEC.EXE is + already provided and can be used immediately by inserting its pathname + in your .XLI control file. + + To generate EXEC.EXE yourself, do the following (substituting + directory names and setting the path as needed; Lattice C version 3.0 + was used): + + lc exec + masm glue_lc; + link \lc\s\c+exec+glue_lc,exec,,\lc\s\lc + + When EXEC.EXE is loaded, it allocates a block of memory from DOS + before returning to PCS. Further external programs, and the Scheme + heap, are allocated with this block unavailable to them. On the + first (XCALL "exec" ...), the block is returned to DOS, and then + DOS can use it to run other programs in. In this approach, nothing + of Scheme needs to be saved or restored, so running another program + is quick. On the other hand, Scheme's heap is that much smaller, + meaning a smaller workspace and more garbage collections. When PCS + terminates, this program's termination code makes certain that the + block gets deallocated (in case it never got called in the first place). +*/ + + + + + +#include "dos.h" + +#define F_NEAR 0x0001 +#define F_INTEGER 0x0002 +#define F_PAD 0x0008 + +#define RT_INTEGER 0 + +#define CARRY_BIT 1 + +typedef unsigned short WORD; /* 16-bit unsigned value */ + +extern WORD _psp; /* Lattice C variables */ +extern WORD _tsize; +extern WORD _oserr; + +/* Note xwait and xbye are the actual addresses we'll jump to when we + call XLI from the glue routine. C calls the glue routine at the + two entry points xli_wait and xli_bye. These 2 routines set + up the stack for calling xwait and xbye. */ +WORD xwait[2]; /* XLI entry points */ +WORD xbye[2]; + +struct xli_file_struct { + WORD id; + WORD flags; + WORD table[2]; /* offset in 0, segment in 1 */ + WORD parm_block[2]; + WORD reserved[8]; +} file_block; + +struct xli_routine_struct { + WORD select; + WORD special_service; + WORD ss_args[8]; + WORD reserved[8]; + WORD return_type; + int return_value; + int dummy[3]; + char *arg[16]; /* position 0 == filename */ + /* positions 1..15 are for args */ +} parm_block; + +char table[] = +/* 0 2 4 6 8 10 12 */ + "exec//"; + + +void main(argc,argv) +int argc; +char *argv[]; +{ + int i,flags,allocated; + WORD psp; +/*WORD memsize; */ + WORD buffer[2]; + WORD block_ptr; + union REGS regs; + struct SREGS segregs; + int xli_wait(); + void xli_bye(); + char *getenv(); + long atol(); + char cmd[128]; + char *local_argv[17]; /* use positions 1..16 */ + +/* -------------------- XLI-specific initialization ----------------------- */ + + /* Note PSP@ is not necessarily directly accessible in any + Lattice C memory model. */ + psp = *(&_psp+1); /* get seg addr of PSP */ + + /* init file block */ + file_block.id = 0x4252; + file_block.flags = F_NEAR+F_INTEGER; + file_block.table[0] = (WORD) table; + file_block.parm_block[0] = (WORD) &parm_block; + segread(&segregs); + file_block.table[1] = segregs.ds; + file_block.parm_block[1] = segregs.ds; + + /* determine link address */ + buffer[0] = (WORD) &file_block; + buffer[1] = segregs.ds; + + /* determine size to keep */ +/*memsize = _tsize; */ /* done in glue routine for S Lattice */ + + /* establish the link addresses between C and PCS */ + poke((int) psp, 0x5c, (char *) buffer, 4); /* poke file block@ into PSP */ + peek((int) psp, 0x0a, (char *) xwait, 4); /* get DOS ret@ */ + xbye[0] = xwait[0]; + xbye[1] = xwait[1]; + xwait[0] += 3; /* incr by 3 for normal call */ + xbye[0] += 6; /* incr by 6 for termination */ + +/* ==================== start program-specific actions ==================== */ + +/* ----------------------------- initialization --------------------------- */ + + /* allocate a block of memory */ + regs.x.ax = 0x4800; /* alloc mem */ + { /* Set size from "XLI" env variable if available; unit size is Kb. + If var doesn't exist, use 64 Kb. Convert to paragraphs. */ + char *block_reserve; + + block_reserve = getenv("XLI"); + regs.x.bx = (block_reserve ? atol(block_reserve) * 1024 / 16 + : 0x1000); + } + flags = intdos(®s,®s); + block_ptr = (flags & CARRY_BIT) ? 0 : regs.x.ax; + allocated = 1; + + /* set all args to -1; since there are a variable # of args, + a -1 after them delimits them */ + for (i = 0; i < 16; i++) parm_block.arg[i] = (char *) -1; + +/* ----------------------------- handler loop --------------------------- */ + + while (xli_wait()) { + + if (!block_ptr) continue; /* couldn't alloc, just skip */ + + /* deallocate the block to leave a hole in which we can bid programs */ + if (allocated) { + regs.x.ax = 0x4900; /* dealloc mem */ + segregs.es = block_ptr; /* @block we previously allocated */ + flags = intdosx(®s,®s,&segregs); + allocated = 0; + } /* end if */ + + switch (parm_block.select) { + int i,error; + + case 0: /* get name of executable file */ + parm_block.special_service = 1; + parm_block.ss_args[0] = 0; + parm_block.ss_args[1] = 128; + parm_block.ss_args[2] = (WORD) cmd; + (void) xli_wait(); + *(cmd + parm_block.ss_args[0]) = '\0'; + + /* get arguments to executable file */ + for (i = 1; i < 17; i++) local_argv[i] = NULL; + for (i = 1; i < 16; i++) { + if ((int) parm_block.arg[i] == -1) break; + local_argv[i] = cmd + parm_block.ss_args[0] + 1; + parm_block.special_service = 1; + parm_block.ss_args[0] = i; + parm_block.ss_args[1] = cmd + 128 - local_argv[i]; + parm_block.ss_args[2] = (WORD) local_argv[i]; + (void) xli_wait(); + *(local_argv[i] + parm_block.ss_args[0]) = '\0'; + } + + /* exec the file and return the termination code */ + /* or -1 if the file doesn't exist */ + error = forkvp(cmd,local_argv); + parm_block.return_value = (error == -1 ? -1 : wait()); + break; + default: ; + } /* end switch */ + parm_block.return_type = RT_INTEGER; + for (i = 0; i < 16; i++) parm_block.arg[i] = (char *) -1; + } /* end while */ + +/* ----------------------------- termination --------------------------- */ + + /* in case this program was never called, the block we reserved */ + /* is still allocated, so deallocate it */ + if (allocated) { + regs.x.ax = 0x4900; /* dealloc mem */ + segregs.es = block_ptr; /* @block we previously allocated */ + flags = intdosx(®s,®s,&segregs); + allocated = 0; + } /* end if */ + + xli_bye(); + +} /* end main */ + \ No newline at end of file diff --git a/xli/exec.doc b/xli/exec.doc new file mode 100644 index 0000000..6586cb3 --- /dev/null +++ b/xli/exec.doc @@ -0,0 +1,72 @@ +"exec" + +"exec" runs an application program from PC Scheme. + + +Format: (XCALL "exec" ) + +Parameter: is a string containing the name of an executable + file; the file extension need not be supplied. The path + will be searched if the program does not reside in the + current directory. + + is a string containing all the arguments to + . + +Explanation: "exec" runs an executable file from PC Scheme. + "exec" operates similarly to DOS-CALL, but when used + in the proper circumstances it can be much faster. + The following three expressions, the first using "exec", + the second using DOS-CALL, and the third as you + would type it from DOS, have equivalent effect: + + (XCALL "exec" "prog" "arg1 arg2") + + (DOS-CALL "prog.exe" "arg1 arg2") + + prog arg1 arg2 + + By default "exec" allocates a 64K memory + block in which to run programs. The space allocated + can be changed through the DOS environment variable + "XLI"; its value is the number of kilobytes to reserve. + This must be done before entering PC Scheme. For + example, to reserve 32K, you would type in this + expression to DOS before invoking PC Scheme: + + set XLI = 32 + + The space reserved by "exec" is unavailable for Scheme's + heap, thereby diminishing the "usual" heap size. + + The return value from "exec" is the exit code + provided by the called program if it successfully + executed or -1 if the program could not be found + anywhere in the path. + + "exec" is superior to DOS-CALL when you need quick + access to programs and you can give up heap space to do + so. "exec" also provides for path searching and returning + a program's exit code. DOS-CALL is preferable in those + cases where larger programs are run or you need maximal + heap space, and these considerations outweigh the loss + of speed that comes from having to move Scheme out of the + way to make room for the program. + +Examples: + (XCALL "exec" "edlin" "\\autoexec.bat") + ;edit the file \autoexec.bat with DOS EDLIN editor; + ;remember the double backslash inside Scheme strings + + (XCALL "exec" "chkdsk") + ;runs the DOS CHKDSK program + + (XCALL "exec" "command" "/c dir *.s") + ;this shows how to execute DOS intrinsic commands + ;such as the DOS directory command--this lists + ;all Scheme source files in the current directory; + ;control returns immediately to PC Scheme + + (XCALL "exec" "command") + ;starts a secondary DOS command processor; + ;use DOS EXIT command to return to PC Scheme \ No newline at end of file diff --git a/xli/exec.exe b/xli/exec.exe new file mode 100644 index 0000000000000000000000000000000000000000..44729af458594861184ce275078590bfc1062973 GIT binary patch literal 7450 zcmeHMe{d94o`2Kb>6uI>lOYL1gg7KDMl@_lFkk zN8N%+!T^`fOORW)?#jE>GCSTK-tJMzrMMA17?@N-vPKD5?rfqS2pk<7_aayX2}R%M zbx#6%a^-(lb#+Z;X5ROGf4%SfzVG+*nn#|PYs(@WDIh-}hVh=QjjX$y;PK(l209^j zHvIqR|7ZlR#s1Q^D;ayww(G>ZZDjXUSF&rc_~_fhsd%)Av=<3?K!Sx^Nulje&xfM_=%D;nTQ+8(>te5TsU!Il`Jqh)wi4M z7?dA{tW=pU*HkW1s4BI@Nx*NNg2lgG$}k}>j` z^-mXeADl2MPPK@pNG)1UCCW1y1XtjwKkH-YB`4u(7R6XiRfGs z^^qd#<4AEbGz@ZrCa@vxXD1BRS3sf*h}ft-AqMRkab@olbg1~uYI>c1$d8;&_lfhp z_Uo75oL|WKJ{M#d(b|={T!Be z$v?Q3eq2#jP85E;oz$1LA(#{ROqV||>#wzueFTFAN)BU@Gt1hx7#rk*eGAI^1!9t_ zn8*U9$Q%@y^U58K_2w|WtaGDL*0E5ZFvM~a)YEn&k7k)BL}o(yH>q)jzRgsy9~ukv z|70n{g)@7q2rt%<>gs^b?QU41y34S(rO2~D&;5jt%kzs*)32<|L*7yE{p5O?S{do* z9tsPW_Uf0_qGe?4>?c)gNo*sbCni6i6xWg?F-5o`2B67Je0FVt7$d8P3;koOjmRx!YpKkm)`Oy|}={Y{R`S*#diQe?#!d*B5F&jio7AfRo4$Xhm| zN)B1@$90}cxdW2ZMg}C2fSOGuak+<2Bj4!f9!r4Tg zh=iR)E@YmpqEfah6?97l0n36P7NC-8bM$=3!8d;V0|e_M4pzh@`p$qj%C(VhX;JiJ zP7`gkEXnoPEFuF~iH%TvE}uoVdQ1ic}N`$n@)A}bR&Ky~~O_!cr$M;p7ZgEwJ*`!6J zrxAd&+6_+Eu>uZ*vSr8~N5BY)S}_hvq>nR0keWiU*vzb3W?b}Q&oXvQ)~k|0Ljo0c z#IbvF9hE!?Ck;8aRT6nF4T)x7ngv2!*goGnNeShUD?Mvq){ zA~12*^{DR{iJU?Y@euz>goZz=1|2!0{&+@Gb|CR1ea_~@I|5S5fi;X=9U1%VT7w!C zw7*A~5!e|Xi-9#UG%(i3a8xR7(fe)DDqFPNX6nIeyN-4ZAyjIXx}NJ=FLXU6HYXSk z>wRRnkVT`*caU`X4#S=p?ZvMHgjU4}7AD1P_Y4;v`8A3$z6Zqp5Q?z=A*D{Dv~kM)-RUusAya!@X%tuU##S9I9-_>iI(%-k`Mq+3TQ`guuCncec z$YQ&@oEJ#H_z=%A-t8n>2gxQLMVHHLBhf~Tp5uj-o{c=qYolx_{>q5G6;sBL1fj_7T>P%$~U=&1^}D&8x47XAlBMtbw!@ogud9x)cucia!5X@8iRT z^X(l~pOOyWzmtxV)1+q|scZ;yOXG(=BfnpI4hX|m7p>v2(KMMbbt(TmAg)7f6D@CA z)Gav~Bdm}8*C0nZxxyhtXC))cL@RPMp0p-S_6d~a-;E0@$U$j=F`Nc^! zD9V|gt6imEGz8XaYf!@sNzh}{%BZiAt4N0Djhtq+H1ci}q|=SwC(tBPtfNNAt-XSQ zl}2W5?3SF^7aHOsIKpB?;yC>hMuyB`1~tN=+078LGTDCdeS-RN;3VnZ*?|p1|6|FU zj&)mAm>&3$P@((v4x;8CVr^1TUq4P%G!eSt@KaU(9BH^un7CC&J*upM) zV90D8{WXq)TUm`|+ItKIKm(tQOtrFB(prq_Wl_G#+MrR!3lA8UR3#(2nrjipS4e-QCw1X)QLvnQ@DI(*g{*(M4 za*nCk(x5|+N5UQ=J0}~RlR-x$=rk-@8p=~^IW?b3u1H_DS;kQL&B9!Iu9{x$+)-^? z=#bM);DY*LwFi1pv=W;7=8|Hc7qw|2s|3_NmvkkIkMlz4uGJ5wpbml7MQ!>!A8mt zm?mbHn{xU#$}iw-|99o=5dW)LTVKk?a+vRXv7*#cdMeS)WgPXgazXoR(2?cQa+Fn9 zv=X0=Xq8|t8K+;x>F=rGi~}!|?qE7Fx}aS`5Fnn@FNrorHx6_YO@J|dHb^8^%LQi0 zmslBM^PiZ`yy#|@Y5)e?`&2-%tGR$yIcXhl`>hjexj?L%fz(yl7P~frb#w+-Z68x5JAnGDgn1+9m`i0W z%$JU*n9#$FOXQ4t%Es4cR*dL$ae_@#A%d zPAFVK(wLQrEs+(SdJ#vlw-P96eCgLW2~X-@umREwv&;3zDSfDW0MO7FiM^Rga-(*#n06G3<9QZj1Ugt6?Jl zQGr=UVXcZ`Nja-gd)q*|+a!*aDy=;%zL6Ea1xSe_r%kXQLH}aaol|a^>p!S5Zq;jRAU7;!K9l_=F(s`yGUq%CA6BA#@(El zrXCcC_H$vYsMhDIjoF7QZBzjCRzpsBVBRf%Nl*?qaJWP?=AxEV3@JbZEkCoqm3*2{ z!%p>1>Z`K(2aA*QhE)8b{gFOqgFy_=KSt}bi;qHl-e_bB?>3eTq-6>29F5uh5dE6E z)J*k3jtz_JHEu^>tUd!aO8m=Q9==VIYALJYEeJAxi2kVk`FGlFaQ zR%^FCEQA)Bh44O}g)mQT^qPV7q6zZ}>PApb^1sVz%v14`1s5xD!ve4vyfEYY1-h-k z*W%LXuJ{zidGkD^OUQ+qEqT#U*}$RVr9h<5G$~X_Zsi^p3mSGI?pA!g{Bhctmvc&e zgaz^&0}^>0@RtvorM&K1P9U3|1mXy3npm6wGwx-4uBO0N`i@5KA*uX zk&C#vnxG4NT?g1ykq9@@kcYo)9`{E~P{u$JaMna;{`N6BkIiDsgI+$_DRgF)A7wh7 z`lt!ToaP-CiGv$&Ha|hb9{y@)S_i7LLw{|WikQ%#2jB&@`Uj?zew@Wpv8SlWfPSF_Fu@3Ap^gaJS2q}( z2cm){^HqnFwfk+?&{XjKGQM$Eur>G8VLP!*)-GXcF6)`Im*f4U2Q39Nfcz5o#vZPN z^?V*17jgx(3W&3aqi_fON1FmKW)&Y*-2QmQsO)%wuhaQVqjg8TiP>iF2o~TTTtHAo zXro6PHnu(*IhGX}A!@y|{S4m9Hah$#@rK2$YzU2c9cE~D<~l5D`^;KB!(t&;b{n=q z@houx>B)x;4=w|=-eYs;lY87SC}rP)shbhMS!uP6sN_~|rkPn}o+zv2f-7}(aw9ne zB*z>Ya`KmPUim4uM^;7&czq$IIPl(raj-p>glbbE>Qo9Dca1Sz+_R7rCwNJC3op0} zDKIb}6k75aE^e@ZaXJIW-vqa#CC`^=Ihq-pgk zh~l#HeV$){>DMX7d+)uspy9C^d~DzGSPa|Dhx?9) z&EGWizhoa#Sh?mA@?g`0B(UPKI#R*Hl1uO(mxODx5x$MXACKR+Nh`+wJ)RBZzW~cz BQ+oga literal 0 HcmV?d00001 diff --git a/xli/glue_lc.asm b/xli/glue_lc.asm new file mode 100644 index 0000000..bfa522e --- /dev/null +++ b/xli/glue_lc.asm @@ -0,0 +1,32 @@ + page 84,120 + +dgroup group data +pgroup group prog + +data segment word public 'DATA' +data ends + +prog segment byte public 'PROG' + assume cs:pgroup,ds:dgroup + + extrn _psp:word,_tsize:word + extrn xwait:dword,xbye:dword + public xli_wait,xli_bye + +xli_wait proc near + push _psp+2 + push _tsize + call dword ptr [xwait] + pop ax + pop ax + ret +xli_wait endp + +xli_bye proc near + call dword ptr [xbye] +xli_bye endp + +prog ends + end + + \ No newline at end of file diff --git a/xli/glue_llc.asm b/xli/glue_llc.asm new file mode 100644 index 0000000..b2223de --- /dev/null +++ b/xli/glue_llc.asm @@ -0,0 +1,32 @@ + page 84,120 + +dgroup group data +pgroup group _prog + +data segment word public 'DATA' + extrn _psp:dword,_tsize:dword + extrn xwait:dword,xbye:dword +data ends + +_prog segment byte public '_PROG' + assume cs:pgroup,ds:dgroup + + public xli_wait,xli_bye + +xli_wait proc far + push word ptr _psp+2 + push word ptr _tsize + call dword ptr [xwait] + pop ax + pop ax + ret +xli_wait endp + +xli_bye proc far + call dword ptr [xbye] +xli_bye endp + +_prog ends + end + + \ No newline at end of file diff --git a/xli/glue_ms.asm b/xli/glue_ms.asm new file mode 100644 index 0000000..59026a0 --- /dev/null +++ b/xli/glue_ms.asm @@ -0,0 +1,33 @@ + page 84,120 + +dgroup group _DATA +pgroup group _TEXT + +_DATA segment word public 'DATA' +_DATA ends + + extrn __psp:word,_tsize:word + extrn _xwait:dword,_xbye:dword + +_TEXT segment byte public 'CODE' + assume cs:pgroup,ds:dgroup + + public _xli_wait,_xli_bye + +_xli_wait proc near + push __psp + push _tsize + call dword ptr [_xwait] + pop ax + pop ax + ret +_xli_wait endp + +_xli_bye proc near + call dword ptr [_xbye] +_xli_bye endp + +_TEXT ends + end + + \ No newline at end of file diff --git a/xli/pmath.s b/xli/pmath.s new file mode 100644 index 0000000..5a9ea03 --- /dev/null +++ b/xli/pmath.s @@ -0,0 +1,155 @@ + +; -*- Mode: Lisp -*- Filename: pmath.s + +;--------------------------------------------------------------------------; +; ; +; TI SCHEME -- PCS Compiler ; +; Copyright 1987 (c) Texas Instruments ; +; All Rights Reserved ; +; ; +; Extended Arithmetic Routines using XLI/Lattice C 8087/80287 NDP support ; +; ; +; Bob Beal ; +; ; +;--------------------------------------------------------------------------; + + +(define exact? (lambda (n) #f)) + +(define inexact? (lambda (n) #t)) + +(begin + (define acos) + (define asin) + (define atan) + (define cos) + (define exp) + (define expt) + (define log) + (define sin) + (define sqrt) + (define tan) + (define pi) + ) + +(letrec + ( +; ( *pi* 3.141592653589793) ; pi +; ( *pi/2* (/ *pi* 2)) ; pi/2 +; ( *2pi* (+ *pi* *pi*)) ; 2pi + ( *e* 2.718281828459045) ; e + + (%bad-argument + (lambda (name arg) + (%error-invalid-operand name arg))) + + (power-loop + (lambda (x n a) ; A is initially 1, N is non-negative + (if (zero? n) + a + (power-loop (* x x) + (quotient n 2) + (if (odd? n) (* a x) a))))) + ) + (begin + + (set! sqrt + (lambda (x) + (if (or (not (number? x)) (negative? x)) + (%bad-argument 'sqrt x) + (let ((x (float x))) + (if (zero? x) + x + (xcall "sqrt" (float x))))))) + (set! sin + (lambda (x) + (if (not (number? x)) + (%bad-argument 'sin x) + (xcall "sin" (float x))))) + + (set! cos + (lambda (x) + (if (not (number? x)) + (%bad-argument 'cos x) + (xcall "cos" (float x))))) + + + (set! tan + (lambda (x) + (if (not (number? x)) + (%bad-argument 'tan x) + (xcall "tan" (float x))))) + + (set! atan + (lambda (x . z) + (cond ((not (number? x)) + (%bad-argument 'atan x)) + ((null? z) + (xcall "atan" (float x))) + ((not (number? (car z))) + (%bad-argument 'atan z)) + (else + (xcall "atan2" (float x) (float (car z))))))) + + (set! acos + (lambda (x) + (if (or (not (number? x)) + (>? (abs x) 1.0)) + (%bad-argument 'ACOS x) + (xcall "acos" (float x))))) + + (set! pi (acos -1)) ;it'd be easier to set pi to a constant but make_fsl + ;is not quite up to 8087 long-real precision on + ;literal constants (e.g. (tan (/ pi 4)) is +/- 2 + ;in the last digit via make_fsl, but +/- 0 if typed + ;in at toplevel or computed as here) + + (set! asin + (lambda (x) + (if (or (not (number? x)) + (>? (abs x) 1.0)) + (%bad-argument 'ASIN x) + (xcall "asin" (float x))))) + + (set! log + (lambda (x . base) + (cond ((or (not (number? x)) (<= x 0)) + (%bad-argument 'log x)) + ((null? base) + (xcall "ln" (float x))) + ((eq? (car base) 10) ;the eq? is deliberate + (xcall "log10" (float x))) + ((= (car base) 1.0) + (error "Divide by zero" 'log x (car base))) + (else + (let ((non-e-base (car base))) + (if (or (not (number? non-e-base)) + (not (positive? non-e-base))) + (%bad-argument 'log non-e-base) + (xcall "log" (float x) (float non-e-base)))))))) + + (set! exp + (lambda (x) + (cond ((not (number? x)) + (%bad-argument 'EXP x)) + ((zero? x) 1.0) + ((negative? x) (/ (xcall "exp" (- (float x))))) + ((integer? x) (power-loop *e* x 1)) + (else + (xcall "exp" (float x)))))) + + (set! expt + (lambda (a x) + (cond ((not (number? a)) + (%bad-argument 'EXPT a)) + ((not (number? x)) + (%bad-argument 'EXPT x)) + ((and (zero? a) (zero? x) (not (integer? x))) + (%bad-argument 'EXPT x)) + ((zero? x) (if (integer? a) 1 1.0)) + ((negative? x) (/ (xcall "expt" (float a) (- (float x))))) + ((integer? x) (power-loop a x 1)) + (else + (xcall "expt" (float a) (float x)))))) + )) + \ No newline at end of file diff --git a/xli/read.me b/xli/read.me new file mode 100644 index 0000000..7ef401d --- /dev/null +++ b/xli/read.me @@ -0,0 +1,168 @@ + +READ.ME file for XLI examples + + + +----- Introduction + + +The XLI directory contains source code examples of XLI interfaces +implemented in the following languages: + + Lattice C, version 3.0 + Microsoft C, version 4.0 + Turbo Pascal, version 3.0 + Turbo C, version 1.0 + Microsoft Macro Assembler, version 4.0 + +Instructions for building each executable file are contained in the source +file. The TRIG_xx files build functional duplicates of NEWTRIG.EXE, the +file that implements the transcendental functions in PC Scheme 3.0. If +you have the Lattice C compiler, the instructions given will build the +exact duplicate of NEWTRIG.EXE. + +Two other files, EXEC.C and SOUND.ASM, are XLI programs, distinct from +the above, that you may find useful in their own right. Corresponding +.EXE's are provided so you can use them immediately just by inserting +their pathnames in your .XLI control file. + + +----- Description of files in XLI directory + +READ.ME this file + +TRIG_LC.C Lattice C source (small model) +GLUE_LC.ASM asm routine to link with above; implements far calls to XLI + for small model program +TRIG_LC.XLI XLI control file for above + +TRIG_MS.C Microsoft C source (small model) +GLUE_MS.ASM asm routine to link with above; implements far calls to XLI + for small model program +TRIG_MS.XLI XLI control file for above + +TRIG_TP.PAS Turbo Pascal source + Note: Due to floating point representation differences + between Turbo Pascal and PC Scheme, this file implements + simple add, subtract, and multiply of integers, so the + "trig" designation is a misnomer. +TRIG_TP.XLI XLI control file for above + +TRIG_TC.PAS Turbo C source (small model) +TRIG_TC.XLI XLI control file for above + +PMATH.S Scheme source file that interfaces with NEWTRIG.EXE. + Since XLI routine names inside XCALL's are independent + of the names of the underlying functions that implement + them, this one file should work with any of the executable + files generated from the different sources (except Turbo + Pascal, which implements a different set of examples). + +SOUND.ASM Microsoft Macro Assembler source for + generating sounds on the PC +SOUND.DOC user documentation for SOUND.ASM +SOUND.EXE executable version of SOUND.ASM + +EXEC.C Lattice C source (small model) for running executable + programs via XLI rather than DOS-CALL +EXEC.DOC user documentation for EXEC.C +EXEC.EXE executable version of EXEC.C + + + +----- Debugging XLI external routines - I + + +During the first stages of developing an XLI interface there may be +problems with connecting the external program to PC Scheme (PCS). +This is awkward to debug because XLI bids an external program as a +child task, and the child is not yet in memory where a machine +breakpoint can be installed. The following may help to localize +where such problems lie. + +First enter PC Scheme normally, specifying a non-existant .XLI file +to prevent the non-functioning interface from loading. Then enter +(%XLI-DEBUG 0) and remember the number that is returned. This will +become the offset value we will use below. Exit PCS and reenter +with: + + DEBUG + R + +DEBUG's R command dumps the processor registers. Note the value of +the ES register and add 10 (hex) to it; we will use this as a segment +value. Now if you disassemble PC Scheme with the U command at the +segment:offset, you will see a series of JMP instructions. The first +one represents the completion of bidding the child and is for use +only by XLI. The second and third JMP instructions are the "wait" +and "bye" entry points into XLI for your program. + +Now you can put a breakpoint at the "wait" JMP, then proceed. If +this address is never reached, it says that your program is not +jumping to XLI at the correct spot, and not much else can be done +from the Scheme side to help you. However, if you print the value of +the DOS termination address in your initialization code, it should +match the segment:address that we derived above for the U command. +This provides a useful check that you are indeed peeking into the PSP +at the proper place. Remember that this address is not itself used, +but offsets 3 and 6 from it, to connect with the "wait" and "bye" JMP +instructions. + +Once you can jump to the "wait" address, you can do other consistency +checks. Dumping the stack at SS:SP, the top two words (4 bytes) are +the far return address to your program. If you disassemble the +instructions around this location, you should see the 2 pushes, the +far call, and the 2 pops required to pass information to XLI. The +next word down on the stack is the program's length as calculated by +your program. Oftentimes this may be the hardest quantity to +determine; you should find the examples included on the PC Scheme +diskettes very helpful here, as the different languages listed each +have different ways of determining this value. The next word down on +the stack is the address of your PSP. At location PSP+5C (hex) +should be the file block far pointer. That location, in turn, starts +with the characters "RB" followed by the flags field and the lookup +table and parameter block pointers. At this early stage the +parameter block will probably contain garbage, but the lookup table +should be reasonable, and don't forget the double slashes at its end. + +The code executed up to the point of jumping to the "wait" entry +point will be the same for every XLI interface you write (except +maybe for the file block flags). This makes it straightforward to +use an existing interface as a template for the next one and feel +certain that establishing the connection with XLI will go smoothly. + +Once you are past the initial call to "wait" and you have verified +the above points, you can be certain that XLI has the proper +information for talking with your program. Then you can move on to +getting the individual XCALL's working. Some hints on this are given +in the next section. + + +----- Debugging XLI external routines - II + + +To debug XCALL's, you can do the following: + + DEBUG + G + +This takes you into PC Scheme. To test an XCALL, do (%XLI-DEBUG arg) +where arg=0 says turn off debug, and arg=1 says turn on debug. Then +do your XCALL. You'll enter the debugger positioned at an INT 3 +instruction. (If you just get the Scheme prompt, you forgot to run +PC Scheme under DEBUG.) DEBUG won't let you proceed through this +instruction correctly (P won't move and T steps into DEBUG itself), +but note the IP register. Increment it by 1 to get past the INT 3. +Then step past the RETF. Immediately after the RETF, you are back in +your own code. Segment and base registers are correct, but remember +XCALL doesn't preserve AX through DI registers. The stack should +contain your program length (on top) and PSP segment address. From +your PSP you should be able to find all your other data structures +and verify their contents. + +Don't use DEBUG's Q command to stop PCS and return to DOS. This +aborts PCS and prevents XLI from clearing the external routines from +memory, which reduces the amount of usable memory considerably. +Return instead to Scheme and use (EXIT). + + \ No newline at end of file diff --git a/xli/sound.asm b/xli/sound.asm new file mode 100644 index 0000000..53bd3ac --- /dev/null +++ b/xli/sound.asm @@ -0,0 +1,249 @@ + name sound + title PC Scheme XLI interface to sound + page 84,120 + + + comment ~ + + This program provides access to the PC's sound-generating devices. + It demonstrates an XLI interface written in assembly language. + + User documentation is available under XLI\SOUND.DOC. SOUND.EXE is + already provided and can be used immediately by inserting its pathname + in your .XLI control file. + + To generate SOUND.EXE yourself, do the following (substituting + directory names and setting the path as needed; Microsoft's + Macro Assembler version 4.0 was used): + + masm sound; + link sound; + + ~ + + +DATA segment byte public 'DATA' + assume DS:DATA +datastart = $ + +;----------------------------------------------------------------------------- +; Equates +;----------------------------------------------------------------------------- +ppi_port equ 61h ;Programmable Peripheral Interface port# +timer_port equ 42h ;timer chip port# + ;reset timer is port# + 1 +timer_mask equ 00000001b ;mask to extract timer bit 1=on +spkr_mask equ 00000010b ;mask to extract speaker bit 1=on + +;----------------------------------------------------------------------------- +; XLI +;----------------------------------------------------------------------------- +;;; ----- Equates ----- +; offsets into the PSP +term_addr equ 0Ah +fb_addr equ 5Ch + +;;; ----- Data structures ----- + +; file block +file_block label word + dw 4252h + dw 0011b ;flags = 0,0,16-bit,near + dw offset lookup_table, seg lookup_table + dw offset parm_block, seg parm_block + dw 8 dup (0) ;reserved + +; parameter block +parm_block label word + dw 0 ;selector + dw 0 ;ssr + dw 8 dup (0) ;ssr args + dw 8 dup (0) ;reserved + dw 0 ;return value type + dw 4 dup (0) ;return value + ; begin arguments +over dw ? ;overlay the 2 sound sources? (you and timer) + ; 0 - enable/disable sound commands + ; 1 - timer only + ; (processor-speed independent) + ; 2 - manual control only + ; (processor-speed dependent) + ; 3 - overlay manual control with timer + ; (processor-speed dependent) + ; 4 - speaker off +freq dw ? ;timer chip set to this frequency +dura dw ? ;duration +pitch dw ? ;pitch (silent section) +pitch2 dw ? ;pitch (voiced section) + +; lookup table +lookup_table label word + db 'sound//' + +; other needed values +psp dw ? ;PSP segment address +psize dw ? ;size of program in paragraphs +xwait dw 2 dup (?) ;XLI wait address +xbye dw 2 dup (?) ;XLI bye address + +;----------------------------------------------------------------------------- +; Local data +;----------------------------------------------------------------------------- +;;; ----- Constants ----- +clock dd 1193180 ;main clock frequency (Hz) +;;; ----- Variables ----- +tmask db ? ;reflects state of timer mask +enable dw 1 ;enabled flag; 0=no, 1=yes + +datasize = $-datastart +DATA ends + + +STACK segment word stack 'STACK' +stackstart = $ + dw 16 dup (?) +stacksize = $ - stackstart +STACK ends + + +PROG segment byte public 'PROG' + assume CS:PROG,DS:DATA +progstart = $ + +;----------------------------------------------------------------------------- +; The XLI interface. +;----------------------------------------------------------------------------- + +main proc far ;this file's initial entry point + +; Initialization + + mov AX,data + mov DS,AX + mov psp,ES ;save PSP@ + mov word ptr ES:fb_addr,offset file_block ;poke file block@ + mov word ptr ES:fb_addr+2,seg file_block ;into PSP + mov AX,ES:term_addr ;calc ptrs in PCS to jump to + add AX,3 + mov xwait,AX + add AX,3 + mov xbye,AX + mov AX,ES:term_addr+2 + mov xwait+2,AX + mov xbye+2,AX + mov psize,plen ;calc program size + +; Suspend this program until an XCALL comes in, or until PCS terminates. + +hloop: push psp + push psize + call dword ptr [xwait] ;connect to PCS + pop ax + pop ax + cmp ax,0 + jnz case0 + call dword ptr [xbye] ;disconnect from PCS + +;----------------------------------------------------------------------------- +; The individual cases (just one, here). +;----------------------------------------------------------------------------- + +case0: + cmp over,0 ;enable/disable sound? + jnz check ;no, jump + mov ax,freq ;set flag appropriately + mov enable,ax + mov dx,0 + jmp short exit ;turn off sound before exiting + +check: cmp enable,0 ;is sound enabled? + jz hloop ;no, exit +; + cmp over,4 ;silence? + jnz s1 ;no, jump + mov dx,freq +exit: in al,ppi_port ;turn off speaker bit + and al,not spkr_mask + out ppi_port,al + cmp dx,0 ;delay before returning? + jne timed ;yes, jump + jmp hloop ;no, return immediately to PC Scheme + +s1: cmp over,1 ;timer only? + jnz s2 ;no, jump + call init_timer + in al,ppi_port + or al,spkr_mask OR timer_mask + out ppi_port,al + cmp dura,0 ;if duration=0, + jz hloop ;exit without turning sound off +timed: mov tmask,0 ;x (time filler) + mov bx,dura +again1: mov cx,pitch + nop ;x + nop ;x + nop ;x +here1a: loop here1a + nop ;x + nop ;x + nop ;x + or al,tmask ;x + mov cx,pitch2 +here1b: loop here1b + dec bx + jnz again1 + xor dx,dx ;clear DX for exiting + jmp exit + +s2: cmp over,2 ;manual control only? + jnz s3 ;no, jump + mov tmask,0 ;reset timer-bit mask +merge: mov bx,dura ;BX is duration + in al,ppi_port +again2: and al,not (spkr_mask OR timer_mask) ;turn off speaker + out ppi_port,al + mov cx,pitch ;CX is first half of pitch half-cycle +here2a: loop here2a + or al,spkr_mask ;turn on speaker + or al,tmask ;include timer bit state + out ppi_port,al + mov cx,pitch2 ;CX is second half of pitch half-cycle +here2b: loop here2b + dec bx + jnz again2 + xor dx,dx ;clear DX for exiting + jmp exit + +s3: cmp over,3 ;both? + jnz error ;no, jump; error + call init_timer + mov tmask,timer_mask ;set timer-bit mask + jmp merge + +error: jmp exit + +main endp + +init_timer proc + mov al,182 ;reset timer chip + out timer_port+1,al + mov ax,word ptr clock ;calc number to give to timer chip + mov dx,word ptr clock+2 ; = 1193180 / freq + mov bx,freq + mov cx,20 ;avoid underflow + cmp bx,cx ;(occurs for divisors <= 18) + jge it_10 + mov bx,cx +it_10: div bx + out timer_port,al ;send number to timer chip + mov al,ah + out timer_port,al + ret +init_timer endp + +progsize = $-progstart +plen equ (progsize+datasize+stacksize+100h+20h)/16 + +PROG ends + end main + diff --git a/xli/sound.doc b/xli/sound.doc new file mode 100644 index 0000000..fcedafc --- /dev/null +++ b/xli/sound.doc @@ -0,0 +1,118 @@ +"sound" + +"sound" activates the speaker. + + +Format: (XCALL "sound" is a number in the range 0..4 which determines + which sound command to execute. + + is the frequency in Hz. Very low and very high + frequencies are mapped to 20 Hz. This number is used for + timer control of the speaker. + + is a number in the range 1..65535. + Zero is mapped to 65536. The speaker is activated for + this many "ticks". + + , are numbers in the range 1..65535. + Zero is mapped to 65536. These numbers are used + for manual control of the speaker, and the sum + + determines the size of 1 "tick". + The length of a tick is processor-speed dependent. + + All arguments are optional. Once given, they remain in effect + until explicitly changed. Also, the meaning of some arguments + may vary depending on = 0 selects overall sound control. = 0 + disables sound commands and <> 0 enables them. The speaker + is turned off. Sound is initially enabled. + + = 2 selects manual control. is ignored--any + number will do as a placeholder. The sum + + determines the pitch through the use of delay loops. The + speaker is off for a delay count of and on for + . Different sums adding up to the same number + give various timbres to the basic pitch. Larger sums decrease + the pitch--doubling the sum will drop the sound one octave, + for example. The sound lasts for ticks before + returning to Scheme. + + = 4 turns off the speaker. If = 0, the + speaker is turned off and control returns immediately to + Scheme. If <> 0, control returns only after + ticks. + +Examples: (XCALL "sound" 0 1) + ;enable sound commands if they were disabled + + (XCALL "sound" 1 440 2000 200 200) + ;on any computer, gives the "A" (= 440 Hz) + ;above middle C. The last 3 parameters are duration + ;values--increasing them give longer durations. + ;The sum 200+200 determines the length of 1 tick + ;and the sound lasts for 2000 ticks. + + (XCALL "sound" 1 256) + ;an example of defaulting--the frequency changes + ;to middle C (= 256 Hz) and other parameters are + ;unchanged + + (XCALL "sound" 2 256 200 1075 1075) + ;on a TI Business-Pro (turbo mode), gives roughly the + ;same "A" above middle C. The sum 1075+1075 determines + ;the pitch and the sound lasts for 200 ticks. + ;The "256" argument is ignored. + + (XCALL "sound" 3 256 200 1075 1075) + ;sounds similar to previous example except now a + ;256 Hz sound (middle C) is superimposed + + (XCALL "sound") + ;repeats the previous sound + + (XCALL "sound" 1 440 0) + ;sound "A" and return to Scheme, leaving the sound on + + (XCALL "sound" 4 0) + ;turn off the sound + \ No newline at end of file diff --git a/xli/sound.exe b/xli/sound.exe new file mode 100644 index 0000000000000000000000000000000000000000..a7019cb3c48f48456545d59dafbdb989b0a4f1f1 GIT binary patch literal 946 zcmeZ`+Qi7jz`~%wz`*eTKRb~2-^swh$sh;hGcvFNNiHyplR*?HItqqc2n0DXGlT#= zB|}Az73Y`crReJ;n|Q}W2$Y@(gB=VEeK&g8q8ZeVv&8_F1F1L=wUCQ}m6>62JeW)d z@_85*Co(KfWjM|j%b?5f-z*x4V;TO-#WO@i*fKDbviz4zW@xta0y4Q5`Y7rBtw6%!lDgqRQWAiOs(lN+nAE z%VuEcmh)ri<_ln$Fk!-@e?Wo@DA>&x#PH~!cj~hO^TKq7Zm~?Dg+2^BMHsAa)-rY9 O{QmiwQ`eDaPKN, __CDECL__ +PubSym@ _envseg, , __CDECL__ +PubSym@ _envSize,, __CDECL__ +PubSym@ _psp, , __CDECL__ +PubSym@ _tsize, , __CDECL__ ; 2nd change *** line added ***. +PubSym@ _version,