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 0000000..44729af Binary files /dev/null and b/xli/exec.exe differ 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 0000000..a7019cb Binary files /dev/null and b/xli/sound.exe differ diff --git a/xli/trig_lc.c b/xli/trig_lc.c new file mode 100644 index 0000000..6b8a397 --- /dev/null +++ b/xli/trig_lc.c @@ -0,0 +1,143 @@ +/*---------------------------------------------------------*/ +/* PC Scheme 3.0 Transcendental Function Support */ +/* (c) Copyright 1987 by Texas Instruments Incorporated */ +/* All Rights Reserved. */ +/*---------------------------------------------------------*/ + +/* + This program is the Lattice C (version 3.0) implementation of the + transcendental functions in PC Scheme, version 3, and is the one + officially supported. The file NEWTRIG.EXE on the Scheme diskettes is + the compiled version of this file. + + Because this file uses the S (small) memory model, it requires a small + assembly language program to do the far calls to the XLI "wait" and "bye" + routines; refer to GLUE_LC.ASM. + + To build TRIG_LC.EXE (which is just NEWTRIG.EXE renamed), perform the + following steps; you may need to substitute directory names and set + your path accordingly. + + lc trig_lc + masm glue_lc; + link \lc\s\c+trig_lc+glue_lc,trig_lc,,\lc\s\lcm+\lc\s\lc + + Lattice C's version 3 math library is a sensing library able to use + an 8087/80287 if it is available or emulate it otherwise. It is + possible to split the library apart into the 8087 and non-8087 versions, + which will make each one smaller (particularly the 8087 version), but + then you can run each version only on a properly equipped machine. + Refer to the Lattice documentation for details on how to do this. +*/ + + +#include "dos.h" +#include "math.h" + +#define F_NEAR 0x0001 +#define F_PAD 0x0008 + +#define RT_DOUBLE 3 + +typedef unsigned short WORD; /* 16-bit unsigned value */ + +extern WORD _psp; /* Lattice C variables */ +extern WORD _tsize; + +/* 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; + double return_value; + double arg1; + double arg2; +} parm_block; + +char table[] = +/* 0 2 4 6 8 10 12 */ + "sqrt/sin/cos/tan/asin/acos/atan/atan2/exp/expt/ln/log10/log//"; + + +void main(argc,argv) +int argc; +char *argv[]; +{ + WORD psp; +/*WORD memsize; */ + WORD buffer[2]; + struct SREGS segregs; + int xli_wait(); + void xli_bye(); + + /* 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_PAD; + 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 */ + + while (xli_wait()) { + switch (parm_block.select) { + case 0: parm_block.return_value = sqrt(parm_block.arg1); break; + case 1: parm_block.return_value = sin(parm_block.arg1); break; + case 2: parm_block.return_value = cos(parm_block.arg1); break; + case 3: parm_block.return_value = tan(parm_block.arg1); break; + case 4: parm_block.return_value = asin(parm_block.arg1); break; + case 5: parm_block.return_value = acos(parm_block.arg1); break; + case 6: parm_block.return_value = atan(parm_block.arg1); break; + case 7: parm_block.return_value = + atan2(parm_block.arg1,parm_block.arg2); break; + case 8: parm_block.return_value = exp(parm_block.arg1); break; + case 9: parm_block.return_value = + pow(parm_block.arg1,parm_block.arg2); break; + case 10: parm_block.return_value = log(parm_block.arg1); break; + case 11: parm_block.return_value = log10(parm_block.arg1); break; + case 12: parm_block.return_value = + log(parm_block.arg1) / log(parm_block.arg2); break; + default: ; + } /* end switch */ + parm_block.return_type = RT_DOUBLE; + } /* end while */ + + xli_bye(); + +} /* end main */ + \ No newline at end of file diff --git a/xli/trig_lc.xli b/xli/trig_lc.xli new file mode 100644 index 0000000..548475c --- /dev/null +++ b/xli/trig_lc.xli @@ -0,0 +1 @@ +trig_lc.exe diff --git a/xli/trig_llc.c b/xli/trig_llc.c new file mode 100644 index 0000000..b7f10af --- /dev/null +++ b/xli/trig_llc.c @@ -0,0 +1,121 @@ +/*---------------------------------------------------------*/ +/* PC Scheme 3.0 Transcendental Function Support */ +/* (c) Copyright 1987 by Texas Instruments Incorporated */ +/* All Rights Reserved. */ +/*---------------------------------------------------------*/ + +/* + This program is a Large Model Lattice C (version 3.0) implementation of + the transcendental functions in PC Scheme, version 3, and is the one + officially supported. The associated assembly language file GLUE_LLC.ASM + is required set up the "wait" and "bye" routines. + + To build TRIG_LLC.EXE, perform the following steps; you may need to + substitute directory names and set your path accordingly. + + lc -ml trig_llc + masm glue_llc; + link \lc\l\c+trig_llc+glue_llc,trig_llc,,\lc\l\lcm+\lc\l\lc +*/ + + +#include "dos.h" +#include "math.h" + +#define RT_DOUBLE 3 /* Designates return value of double float */ + +typedef unsigned long DWORD; /* 32-bit unsigned value */ +typedef unsigned short WORD; /* 16-bit unsigned value */ + +extern char *_psp; /* Lattice C variable - ptr to psp address */ +extern WORD _tsize; /* Lattice C variable - size of program */ + +/* +Note xwait and xbye are the actual addresses we'll jump to when we call XLI +from the glue routine. We call the glue routine at the two entry points xli_wait +& 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; + char *table; /* pointer to lookup table */ + char *parm_block; /* pointer to parameter block */ + WORD reserved[8]; +} file_block; + +struct xli_routine_struct { + WORD select; + WORD special_service; + WORD ss_args[8]; + WORD reserved[8]; + WORD return_type; + double *return_value; /* return value = pointer to double float */ + DWORD dummy; /* dummy out rest of return value field */ + double *arg1; /* pointer to argument 1, a double float */ + double *arg2; /* pointer to argument 2, a double float */ +} parm_block; + +char table[] = +/* 0 2 4 6 8 10 12 */ + "sqrt/sin/cos/tan/asin/acos/atan/atan2/exp/expt/ln/log10/log//"; + + +void main(argc,argv) +int argc; +char *argv[]; +{ + int xli_wait(); /* xli glue routines */ + void xli_bye(); + + char *buffer; /* temp to hold address of file block */ + + /* initialize the file block */ + file_block.id = 0x4252; /* identify as xli routines */ + file_block.flags = 0; /* far model, don't pack args */ + file_block.table = table; /* address of lookup table */ + file_block.parm_block = &parm_block; /* address of parameter block */ + + buffer = (char *) &file_block; /* hold address of file block,*/ + movmem(&buffer, (_psp+0x5c), 4); /* then move it into PSP+0x5C */ + + movmem((_psp+0xa), (char *) &xwait, 4); /* get callers return address */ + xbye[0] = xwait[0]; /* into xwait and xbye */ + xbye[1] = xwait[1]; + xwait[0] += 3; /* calc normal return address */ + xbye[0] += 6; /* calc termination address */ + + /* + Initialization complete - return to xli. The following loop will execute + until xli gives us a non-zero value + */ + while (xli_wait()) { + parm_block.return_value = parm_block.arg1; /* use arg1 for return value */ + switch (parm_block.select) { + case 0: *parm_block.return_value = sqrt(*parm_block.arg1); break; + case 1: *parm_block.return_value = sin(*parm_block.arg1); break; + case 2: *parm_block.return_value = cos(*parm_block.arg1); break; + case 3: *parm_block.return_value = tan(*parm_block.arg1); break; + case 4: *parm_block.return_value = asin(*parm_block.arg1); break; + case 5: *parm_block.return_value = acos(*parm_block.arg1); break; + case 6: *parm_block.return_value = atan(*parm_block.arg1); break; + case 7: *parm_block.return_value = + atan2(*parm_block.arg1,*parm_block.arg2); break; + case 8: *parm_block.return_value = exp(*parm_block.arg1); break; + case 9: *parm_block.return_value = + pow(*parm_block.arg1,*parm_block.arg2); break; + case 10: *parm_block.return_value = log(*parm_block.arg1); break; + case 11: *parm_block.return_value = log10(*parm_block.arg1); break; + case 12: *parm_block.return_value = + log(*parm_block.arg1) / log(*parm_block.arg2); break; + default: ; + } /* end switch */ + parm_block.return_type = RT_DOUBLE; /* return type = double float */ + } /* end while */ + + xli_bye(); /* terminate xli routine */ + +} /* end main */ + \ No newline at end of file diff --git a/xli/trig_ms.c b/xli/trig_ms.c new file mode 100644 index 0000000..dfad649 --- /dev/null +++ b/xli/trig_ms.c @@ -0,0 +1,173 @@ +/* + This program is the Microsoft C (ver. 4.0) implementation of the + transcendental functions. The official implementation used by PC SCHEME + was done under the Lattice C version. This purpose of this program is to + show you what is needed to communicate with XLI via MS C. The + lines containing comments that start out with @@ designate lines that + will need to be modified by you when you use this template program + for your own purpose. + + Note: Before linking this program you will need to use the Macro + Assembler to assemble the file GLUE_MS.ASM. The output of + the assembler, GLUE_MS.OBJ will then be linked with the object + of this file created by MSC. + + The command line to compile is: + MSC trig_ms; + + The command line to assemble is: + MASM glue_ms; + + The command line to link this program is: + LINK trig_ms+glue_ms; +*/ + +#include "dos.h" +#include "math.h" +#include "stdlib.h" + +#define F_NEAR 0x0001 /* Set model flag to near. USED */ +#define F_INT 0x0002 /* Set integer flag to 16 bits. NOT-USED */ +#define F_REL 0x0004 /* Set release env block by extern pgm flag. N-U */ +#define F_PAD 0x0008 /* Set parm blocking flag to unblocked. USED */ + +#define RT_INTEGER 0 /* Set return type to be an integer. NOT-USED */ +#define RT_BOOLEAN 1 /* Set return type to be boolean. NOT-USED */ +#define RT_STRING 2 /* Set return type to be a string. NOT-USED */ +#define RT_DOUBLE 3 /* Set the return type to be a float num. USED */ + +typedef unsigned short WORD; /* 16-bit unsigned value */ + +/* + Xwait and xbye will contain the actual addresses, XLI entry points, that + we'll jump to when we call XLI so they need to be big enough to hold FAR + pointers. +*/ +WORD xwait[2]; +WORD xbye[2]; + +WORD tsize; /* Will contain the length of this program in paragraphs. */ + +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; + double return_value; + double arg1; /* @@ Add as many args as you need. */ + double arg2; +} parm_block; + +char table[] = +/* + @@ The following string contains the names of the functions that can + be called from within SCHEME when this file is loaded thru XLI. + + 0 1 2 3 4 5 6 7 8 9 10 11 12 +*/ + "sqrt/sin/cos/tan/asin/acos/atan/atan2/exp/expt/ln/log10/log//"; + + +void main() +/* + Within the main body of code the only portions that you will need to + change are: + 1) The value of the FILE-BLOCK.FLAGS and + 2) The functions that you will call from within the CASE stmts. +*/ +{ + struct SREGS segregs; + +/* + These function are defined in the assembly file GLUE_MS.ASM and are + the functions that interface with Schemes XLI. +*/ + int xli_wait(); + void xli_bye(); + + + union { + WORD far * psp_ptr; /* declare as a far 32 bit pointer. */ + WORD half_ptrs[2]; /* declare two 16 bit words for Seg & Off. */ + } ptr; + +/* + The following code will initialize the File Block as needed. +*/ + file_block.id = 0x4252; + file_block.flags = F_NEAR+F_PAD; /* @@ Set flags as appropiate. */ + + segread(&segregs); /* Obtain the register information. */ + file_block.table[0] = (WORD) table; + file_block.table[1] = segregs.ds; + file_block.parm_block[0] = (WORD) &parm_block; + file_block.parm_block[1] = segregs.ds; + + +/* + The word at the PSP+2 is set by MS C to contain the next available + paragraph number after this program. So if we subtract from this + address the address of the PSP then we get the size of this program + in paragraphs. +*/ + ptr.half_ptrs[0] = 2; /* Set the offset to two, */ + ptr.half_ptrs[1] = _psp; /* and the segment to the PSP. */ + tsize = *(ptr.psp_ptr) - _psp; + + + ptr.half_ptrs[0] = 0; /* Set the offset to zero, */ + ptr.half_ptrs[1] = _psp; /* and the segment to the PSP. */ + +/* + Establish the connection between C and the PSP. +*/ + ptr.psp_ptr[46] = (WORD far) &file_block; /* Set into the PSP the offset and */ + ptr.psp_ptr[47] = segregs.ds; /* segment address of file_block */ + + xwait[0] = ptr.psp_ptr[5]; /* Store into XWAIT the offset and */ + xwait[1] = ptr.psp_ptr[6]; /* segment address of DOS's terminate routine. */ + + xbye[0] = xwait[0]; /* Copy the termination segment and */ + xbye[1] = xwait[1]; /* offset address, from above, into here. */ + + xwait[0] += 3; /* incr by 3 for normal call */ + xbye[0] += 6; /* incr by 6 for termination */ + + while (xli_wait()) { + switch (parm_block.select) { + case 0: parm_block.return_value = sqrt(parm_block.arg1); break; + case 1: parm_block.return_value = sin(parm_block.arg1); break; + case 2: parm_block.return_value = cos(parm_block.arg1); break; + case 3: parm_block.return_value = tan(parm_block.arg1); break; + case 4: parm_block.return_value = asin(parm_block.arg1); break; + case 5: parm_block.return_value = acos(parm_block.arg1); break; + case 6: parm_block.return_value = atan(parm_block.arg1); break; + case 7: parm_block.return_value = + atan2(parm_block.arg1,parm_block.arg2); break; + case 8: parm_block.return_value = exp(parm_block.arg1); break; + case 9: parm_block.return_value = + pow(parm_block.arg1,parm_block.arg2); break; + case 10: parm_block.return_value = log(parm_block.arg1); break; + case 11: parm_block.return_value = log10(parm_block.arg1); break; + case 12: parm_block.return_value = + log(parm_block.arg1) / log(parm_block.arg2); break; + default: ; + } /* end switch */ + + parm_block.return_type = RT_DOUBLE; + + } /* end while */ + + xli_bye(); + +} /* end main */ + \ No newline at end of file diff --git a/xli/trig_ms.xli b/xli/trig_ms.xli new file mode 100644 index 0000000..665ce22 --- /dev/null +++ b/xli/trig_ms.xli @@ -0,0 +1 @@ +trig_ms.exe diff --git a/xli/trig_tc.c b/xli/trig_tc.c new file mode 100644 index 0000000..285bf83 --- /dev/null +++ b/xli/trig_tc.c @@ -0,0 +1,233 @@ +/* + This program is the TURBO C (ver. 1.0) implementation of the + transcendental functions. The official implementation used by SCHEME was + done under the Lattice C version. This purpose of this program is to + show you what is needed to communicate with XLI via TURBO C. The + lines containing comments that start out with @@ designate lines that + will need to be modified by you when you use this template program + for your own purpose. + + Note: In order to compile this program you will need to have a path + set up to get to the Macro Assembler. + + The command line to compile is: + TCC -ID:\TURBOC\INCLUDE -LD:\TURBOC\LIB -B -c TRIG_TC + + The command line to link this program is: + TLINK d:\turboc\lib\c0new.obj TRIG_TC,,,d:\turboc\lib\emu + d:\turboc\lib\maths d:\turboc\lib\cs + + All pathnames will need to be changed to reflect your directories. The + command for the link needs to be on one line only. The file C0NEW.OBJ + was my changed copy of the C0S.OBJ file; the changes you need to make to + it are described below. + +*/ + +#include "dos.h" +#include "math.h" +#include "stdlib.h" + +#define F_NEAR 0x0001 /* Set model flag to near. USED */ +#define F_INT 0x0002 /* Set integer flag to 16 bits. NOT-USED */ +#define F_REL 0x0004 /* Set release env block by extern pgm flag. N-U */ +#define F_PAD 0x0008 /* Set parm blocking flag to unblocked. USED */ + +#define RT_INTEGER 0 /* Set return type to be an integer. NOT-USED */ +#define RT_BOOLEAN 1 /* Set return type to be boolean. NOT-USED */ +#define RT_STRING 2 /* Set return type to be a string. NOT-USED */ +#define RT_DOUBLE 3 /* Set the return type to be a float num. USED */ + +typedef unsigned short WORD; /* 16-bit unsigned value */ + +/* + _tsize is set to the size of the program from within the Start Up Code + file called C0.ASM. You need to modify this file in order for this + variable to be set. + + The file C0.ASM is supplied to you on the TURBO C diskette. It is + in assembly source form so that you can modify the Start Up Code to + do what you need it to do. In this case we will make the following + changes to capture the in-memory size of this file in paragrahps. + + The following two pieces of code are extracted out of the file + C0.ASM. They show you where the changes need to be made so that _tsize + will contain the size of this, or your, program. Only two lines need + to be added to the C0.ASM file. You will then need to execute the batch + file that TURBO provides you, called BUILD-C0, in order to build a new + C0x.OBJ file, where the 'x' represents the model. To create a new small + model after making the changes shown below you would execute the batch + stream by typing BUILD-C0 SMALL. + +ExcessOfMemory label near + mov bx, di + add bx, dx + mov word ptr _heapbase@ + 2, bx + mov word ptr _brklvl@ + 2, bx + mov ax, _psp@ + sub bx, ax ; BX = Number of paragraphs to keep + mov _tsize@, bx ; 1st change *** Line added for XLI *****. + mov es, ax ; ES = Program Segment Prefix address + mov ah, 04Ah + int 021h + . + . + . +PubSym@ _envLng, , __CDECL__ +PubSym@ _envseg, , __CDECL__ +PubSym@ _envSize,, __CDECL__ +PubSym@ _psp, , __CDECL__ +PubSym@ _tsize, , __CDECL__ ; 2nd change *** line added ***. +PubSym@ _version,