; ======> PROSPRIN.ASM ;************************************************************************ ;* PC Scheme Runtime Support - Sexpression Print Routines * ;* * ;* (C) Copyright 1985 by Texas * ;* Instruments Incorporated. * ;* All rights reserved. * ;* * ;* Date Written: 24 March 1986 * ;* * ;* Modifications: * ;* * ;* 11/27/87 (tc) Rewritten for protected mode scheme. Also * ;* modified to buffer the output more effectively. * ;* * ;************************************************************************ page 60,132 title PC Scheme Print Handlers include scheme.equ include sinterp.arg include xli_pro.mac NUMBER_SPECIAL_CHARS equ 8 ;special chars defined in cread.asm RETURN equ 0Dh SPACE equ 20h SYM_OVHD equ 7 HEAPERR equ -3 DGROUP group data data segment word public 'DATA' assume DS:DGROUP public display, show, ccount ;from sread.asm extrn test_ch:word extrn t_array:word ;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 iosupport.asm extrn port_seg:word,port_pg:word,port_ds:word ;from ??? extrn hicases:byte ;Table of strange characters used by printatm stranges db " ,'" db ';":()`' db 13,12,11,10,9,0 ; ; The following global data is used to tell the print handlers about ; the print characteristics, ie. to surround strings with double quotes, ; to display escape characters, etc. ; ; display dw 0 ; whether to surround atoms/strings with | or " show dw 1 ; whether actually printing chars or not ccount dw 0 ; char count used to determine print length ; ; Branch table of all Scheme object print handlers ; branchtab dw sp_list ; [0] LISTTYPE dw sp_fix ; [1] FIXTYPE dw sp_flo ; [2] FLOTYPE dw sp_big ; [3] BIGTYPE dw sp_sym ; [4] SYMTYPE dw sp_str ; [5] STRTYPE dw sp_ary ; [6] ARYTYPE dw sp_cont ; [7] CONTTYPE dw sp_clos ; [8] CLOSTYPE dw sp_free ; [9] FREETYPE dw sp_code ; [10] CODETYPE dw subp_ret ; [11] REFTYPE dw sp_port ; [12] PORTTYPE dw sp_char ; [13] CHARTYPE dw sp_env ; [14] ENVTYPE ; ; Following text will be output for those objects which have not ; printable representations. ; 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 "#",0 ab_write db "[WARNING: Output aborted by SHIFT-BREAK]",0 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 extrn next_SP:near extrn src_err:near extrn get_port:near extrn setabort:near,abort:near extrn take_cdr:near,restart:near,stkspc:near extrn copybig:near,fix2big:near,big2asc:near,get_flo:near extrn isspace:near extrn gvchars:near,ssetadr:near extrn scannum:near comment | Commented out 2/10/88 by TC - moved to realio routine ;****************************************************************************** ;WRAP - Local macro definition. If there are less than LEN spaces left on ; the local output line, make AX non-zero to denote wrap necessary. ; ; Note: es:di are destroyed ;****************************************************************************** wrap macro len,result local wrapend push es push di xor result,result ;result = default no wrap cmp show,0 ;are we actually printing? jz wrapend ; no, just return with default LoadPage es,port_pg mov di,port_ds ;es:di => port object cmp es:[di].pt_ncols,0 ;maintaining line length? jz wrapend ; no, return default cmp es:[di].pt_ccol,1 ;in the first column already? jle wrapend ; yes, return default mov result,es:[di].pt_ncols ;ax = number cols sub result,es:[di].pt_ccol ;ax = remaining spaces cmp result,len ;any room left? mov result,0 ; jge wrapend ; yes, return nowrap flag inc result ; no, return wrap flag wrapend: pop di pop es endm | prn_proc proc near ;;;**************************************************************************** ;;; VM Opcode handler for "WRITE" ;;; ;;; Print an S-Expression with slashification ;;; ;;;**************************************************************************** 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: 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 mov display,0 ; default display = no jmp next_SP ; return to interpreter ;;;**************************************************************************** ;;; VM Opcode handler for "DISPLAY" ;;; ;;; Print an S-Expression without slashification ;;; ;;;**************************************************************************** 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 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 ;;;**************************************************************************** ;;; VM Opcode handler for "PRINT" ;;; ;;; Print an S-Expression with spacing control ;;; ;;;**************************************************************************** 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 inc AX mov show,AX mov DX,SPECCHAR mov BX,RETURN ; carriage return pushm call sprint ; print it mov SP,BP xor AX,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 display,AX inc AX mov show,AX pushm call sprint ; print it mov SP,BP jmp sp1_020 ;;;**************************************************************************** ;;; VM Opcode handler for "NEWLINE" ;;; ;;; Output a newline character ;;; ;;;**************************************************************************** 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 inc AX mov show,AX mov BX,SPECCHAR mov DX,RETURN ; carriage return pushm call sprint mov SP,BP mov display,0 ; default display = no jmp next_SP ; return to interpreter ;;;**************************************************************************** ;;; VM Opcode handler for "LINE-LENGTH" ;;; ;;; 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 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 ;************************************************************************** ; SPRINT - Sexpression print routine ; ; Calling Sequence: sprint(pds,ppg,dis,pg) ; ; Where: ppg:pds = page:displacement of port to output to ; pg:dis = scheme object to output ; ; Upon Exit: AX = number of characters printed ; ;************************************************************************** spt_arg struc dw ? ;caller's BP dw ? ;caller's return address pg dw ? ;page num of object to print dis dw ? ;page disp of object to print ppg dw ? ;page num of output port pds dw ? ;page disp of output port spt_arg ends public sprint sprint proc near push BP mov BP,SP ;set up stack call setabort ;set address when abort pushm <[BP].pds, [BP].ppg> call ssetadr ;set port address mov SP,BP ;fix for random i/o - note a write has taken place mov AX,ES ;save extra segment LoadPage ES,port_pg ;address port mov SI,port_ds or byte ptr ES:[SI].pt_pflgs,DIRTY ;note write has occurred mov ES,AX ;restore extra segment mov ccount,0 ;clear character count pushm <[BP].dis, [BP].pg> call subsprin ;go print the object mov SP,BP mov AX,ccount ;return number of characters pop BP ret ;return to caller sprint endp ;************************************************************************** ; SUBSPRIN - Recursive print routine ; ; Calling Sequence: subsprin(dis,pg) ; ; Where: dis = displacement with pg of object to print ; pg = page of object to print ; ;************************************************************************** public subsprin subp_arg struc tmp_reg1 dw ? tmp_reg2 dw ? tmp_reg3 dw ? lst_pag dw ? lst_dsp dw ? 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 call printcha mov AX,41 ;length of message lea BX,ab_write pushm call printtxt ;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 ;# jmp subp_ret ;print message and return ; act on object type subp_20: shl [BP].spg,1 ;adjust page number mov BX,[BP].spg mov DI,ptype+[BX] ;get page type jmp branchtab+[DI] ;envoke appropriate handler ; ; any problems with getmem should exit here mem_err: mov AX,HEAPERR ;memory not available push AX call abort mov SP,BP ; ; return to caller subp_ret: add SP,offset subp_BP ;release local storage pop BP pop ES ret page 60,132 ;----------------------------------------------------------------------------- ; ; Following are the print handlers for each object type, they will be invoked ; via an indirect call through BRANCHTAB. ; ; Upon entry: BX = an adjusted page number ; DI = the page type ; ; Upon exit: Jump to SUBP_RET for cleanup ; ;----------------------------------------------------------------------------- ;******************************************************************************* ; ; Print representation for code block object ; ;******************************************************************************* public sp_code sp_code: mov AX,7 lea BX,code_str ; # jmp subp_txt ;******************************************************************************* ; ; Print representation for continuation object ; ;******************************************************************************* public sp_cont sp_cont: mov AX,15 lea BX,cont_str ; # jmp subp_txt ;******************************************************************************* ; ; Print representation for environment object ; ;******************************************************************************* public sp_env sp_env: mov AX,14 lea BX,env_str ; # jmp subp_txt ;******************************************************************************* ; ; Print representation for free page ; ;******************************************************************************* public sp_free sp_free: mov AX,7 lea BX,free_str ; # jmp subp_txt ;******************************************************************************* ; ; Print representation for port object ; ;******************************************************************************* public sp_port sp_port: mov AX,7 lea BX,port_str ; # subp_txt: pushm ;ax = length, bx = message address call printtxt ;print the message mov SP,BP ;clean up stack jmp subp_ret ;and return to caller ;******************************************************************************* ; ; Print floating point value ; ;******************************************************************************* public sp_flo 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 ;******************************************************************************* ; ; Print list ; ;******************************************************************************* public sp_list sp_list: test bx,bx ;null page? jnz sp_l01 ; no, go chase list mov ax,2 lea bx,parens pushm call printtxt ;print "()" for null list mov sp,bp jmp subp_ret sp_l01: mov al,byte ptr parens call printcha ;print open paren mov bx,[bp].spg LoadPage es,bx mov si,[bp].sdis ;es:si => list cell sp_l02: mov [bp].lst_pag,bx mov [bp].lst_dsp,si ;save list cell xor dh,dh mov dl,byte ptr es:[si] ;get car of list shr dx,1 ; make number for subsprin mov cx,word ptr es:[si+1] ;get car's displacement pushm call subsprin ;print car of list mov sp,bp mov bx,[bp].lst_pag ;restore list cell LoadPage es,bx mov si,[bp].lst_dsp mov bl,byte ptr es:[si+3] ;get cdr of list mov si,word ptr es:[si+4] test bx,bx ;is it null? jz sp_l04 ; yes, finished pushm ;tempsave si,bx mov al,' ' call printcha ;print space as item seperator popm ;restore stack LoadPage es,bx ;reload page of cdr cmp byte ptr ptype+[bx],LISTTYPE*2 ;is cdr a list cell? je sp_l02 ; yes, chase the list ; cdr is not a list cell - improper list mov dx," ." ;need " ." due to byte swapping pushm ;tempsave si,bx - dx is text mov si,sp mov dx,2 pushm ;push length, address of text call printtxt ;print ". " add sp,6 ;dump last 3 args popm ;restore saved regs shr bx,1 ;make page a number for subsprin pushm call subsprin ;go chase last cdr mov sp,bp ;dump args off stack sp_l04: mov al,byte ptr parens+1 call printcha ;and print it mov sp,bp jmp subp_ret ;return to caller ;******************************************************************************* ; ; Print array ; ;******************************************************************************* public sp_ary sp_ary: mov AX,2 LoadPage ES,BX ; page segment lea BX,ary_str ; print "#(" pushm call printtxt 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].lst_dsp,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 ax,SPACE ; print ' ' call printcha mov BX,[BP].tmp_reg2 ; restore registers sp_a02: mov SI,[BP].lst_dsp add BX,PTRSIZE LoadPage ES,[BP].spg ; Reload page address of array jmp sp_a01 ;******************************************************************************* ; ; Print representation for closure object ; ;******************************************************************************* public sp_clos sp_clos: mov ax,11 lea bx,clos_str pushm call printtxt ;print "# closure object lea bx,[bp].tmp_reg1 xor ah,ah mov al,byte ptr es:[si+3] ;pag # of information op mov [bx].C_page,ax ; save in tmp_reg1 mov ax,word ptr es:[si+4] ;displ of information op mov [bx].C_disp,ax ; save in tmp_reg1 ; follow info operand list sp_c001: mov di,[bx].C_page cmp di,0 ;if reached end of list je sp_c04 ; then exit loop cmp byte ptr ptype+[di],LISTTYPE*2 ;if cdr not list cell jne sp_c01 ; then exit loop push bx call take_cdr ;follow cdr of list lea bx,[bp].tmp_reg1 jmp sp_c001 ; If final operand is a symbol, print it sp_c01: cmp byte ptr ptype+[DI],SYMTYPE*2 ;do we have a symbol? jne sp_c04 ; no, jump push bx ;tempsave reg around call mov ax,SPACE call printcha ;print ' ' pop bx ;restore reg push display ;save around call mov display,0 ;don't print escape chars shr [bx].C_page,1 ;make page # for subsprin pushm <[bx].C_disp,[bx].C_page> ;push page:disp of symbol call subsprin ;go print the symbol add sp,4 ;dump args off stack pop display ;restore display indicator sp_c04: mov al,'>' call printcha ;print '>' mov SP,BP jmp subp_ret ;******************************************************************************* ; ; Print symbol to output port ; ;******************************************************************************* public printatm printatm label near sp_sym: ; ; Warning: local data segment is not used in code below ; loadpage ds,bx mov si,[bp].sdis ;ds:si => object mov cx,[si]+1 ;get object length sub cx,SYM_OVHD ;cx = length of atom add SS:ccount,cx ;update character count cmp SS:show,0 ;do we want to print the object? jne pra_010 ; yes, continue mov dx,ss ; no, restore data segment mov ds,dx jmp pra_exit ; and return pra_010: ;cx = length of symbol add si,SYM_OVHD ;ds:si => symbol name GET_BUFFER ;es:di => real buffer call atm2pbuf ;move printname to print buffer ; ; Warning: local data segment is not used in code above ; mov dx,ss mov ds,dx ;restore local data segment cmp cx,0 ;if negative print length jl pra_err ; then error, jump ;;; wrap cx,dx ;cx = length, dx = result mov dx,1 ;check wrap flag ;cx = length, dx = check wrap flag, es:di => print buffer call gvchars ;go print the buffer pra_exit: RLS_BUFFER jmp subp_ret pra_err: jmp mem_err ;******************************************************************************* ; ; Print string to output port ; ;******************************************************************************* public printstr printstr label near sp_str: ; ; Warning: local data segment is not used in code below ; loadpage ds,bx mov si,[bp].sdis ;ds:si => object mov cx,[si]+1 ;cx = length indicator add si,BLK_OVHD ;ds:si => actual string or cx,cx ;small string? jge prs_005 ; no, jump add cx,BLK_OVHD+PTRSIZE prs_005: sub cx,BLK_OVHD ;cx = length of string add SS:ccount,cx ;update character count cmp SS:show,0 ;actually printing? jne prs_010 ; yes, continue mov dx,ss ; no, restore data segment mov ds,dx jmp pra_exit ; and return prs_010: ;cx = string length GET_BUFFER ;es:di => buffer for print string call str2pbuf ;move string to print buffer ; ; Warning: local data segment is not used in code above ; mov bx,ss ;restore local data segment mov ds,bx cmp cx,0 ;if negative print length jl prs_err ; then error, jump ;;; wrap cx,dx ;cx=length, dx=result mov dx,1 ;check wrap flag ;cx = length, dx = check wrap flag, es:di => print buffer call gvchars ;go print the buffer prs_exit: RLS_BUFFER ;release the print buffer jmp subp_ret prs_err: jmp mem_err ;must be a long jump ;******************************************************************************* ; ; Print character to output port ; ;******************************************************************************* public sp_char sp_char: cmp display,0 ;display escape chars? jne sp_ch10 ; yes, jump ;print character without escapes mov ax,[BP].sdis ;get character xor ah,ah call printcha ;call print routine jmp subp_ret ;get outa here ;print character with escapes sp_ch10: mov bx,14 ;max size of character buffer push bx C_call getmem ;allocate space mov sp,bp ;dump arg off stack cmp ax,0 jne sp_ch00 jmp mem_err ;error allocating heap - jump sp_ch00: mov si,ax ;si => buffer mov dx,ax ;dx => buffer mov ax,[BP].sdis ;get character 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 mov bx,3 ;length ; ; see if character one of the multi-character constants in cread.asm ; mov cx,ds mov es,cx ;ensure ds=es mov cx,NUMBER_SPECIAL_CHARS ;cx = counter lea di,test_ch add di,NUMBER_SPECIAL_CHARS-1 ;di => last special char std repne scasb ;search for special char cld jnz sp_ch20 ;if none found, jump shl cx,1 ;make index into t_array lea di,t_array add di,cx mov di,[di] xchg si,di ;ds:si => character string add di,2 ;es:di => character buffer cld xor al,al ;al = null terminator sp_chlp: movsb ;move byte into character buffer cmp al,[si] ;reached terminator? jne sp_chlp sub di,dx ;calc length mov bx,di sp_ch20: pushm ;bx=buffer length, dx=buffer address call printtxt ;print the character constant mov SP,BP mov bx,14 ;length of character buffer pushm C_call rlsmem ;release character buffer mov sp,bp ;dump args off stack jmp subp_ret ;******************************************************************************* ; ; Print integer value ; ;******************************************************************************* public sp_fix sp_fix: mov AX,5 mov [BP].tmp_reg2,AX push AX C_call getmem mov SP,BP or ax,ax jnz sp_f10 jmp mem_err sp_f10: 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 ;******************************************************************************* ; ; Print bignum ; ;******************************************************************************* public sp_big 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].lst_dsp,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 printtxt ; print the bignum mov SP,BP pushm <[BP].tmp_reg2, [BP].tmp_reg1> C_call rlsmem pushm <[BP].lst_dsp, [BP].tmp_reg3> C_call rlsmem mov SP,BP jmp subp_ret subsprin endp ; page 60,132 ; title Print Handler Support Routines ; ;****************************************************************************** ;PRINTTXT - C callable routine to print a string, first sending a newline ; character if necessary. The string is assumed to be in the ; local data segment. ; ; Calling Sequence: printtxt(string,len) ; ;****************************************************************************** str_arg struc dw ? ; caller's BP dw ? ; caller's ES dw ? ; caller's return address str dw ? ; string pointer len dw ? ; string length str_arg ends public printtxt printtxt proc near push es push bp mov bp,sp ;set up stack mov cx,[bp].len ;cx = length of string add ccount,cx ;keep track of character count cmp show,0 ;show? je pstr_ret ; no, return push display mov display,0 mov si,[bp].str ;ds:si => string to write GET_BUFFER ;es:di => buffer for print string call str2pbuf ;move string to print buffer pop display ;;; wrap cx,dx ;cx=length, dx=result mov dx,1 ;check wrap flag ;cx = length, dx = check wrap flag, es:di => print buffer call gvchars ;go print the buffer RLS_BUFFER ;release the print buffer pstr_ret: pop bp pop es ret printtxt endp ;****************************************************************************** ;PRINTCHA - C callable routine to print a character, first sending a newline ; character if necessary. At least for now, this is performed by ; calling gvchars - in the future we may want output routines for ; outputting individual characters. ; ; Upon Entry: al contains character to print ; ;****************************************************************************** pcha_arg struc dw ? ;caller's BP dw ? ;caller's ES dw ? ;caller's return address pcha_arg ends public printcha printcha proc near push es push bp mov bp,sp ;set up stack inc ccount ;bump character count cmp show,0 ;if not actually printing jz pcha_ret ; then return comment | ;see if enough space left on current output line LoadPage es,port_pg mov di,port_ds ;es:di => port object xor dx,dx ;dx = wrap flag (0 = nowrap) mov cx,es:[di].pt_ncols ;maintaining line length? jcxz pcha_010 sub cx,es:[di].pt_ccol ;cx = space remaining cmp cx,1 ;any space left? jge pcha_010 mov dx,1 | mov dx,1 ;check wrap flag pcha_010: RESET_REAL_BUFFER_OFFSET MOVE_BYTE_TO_BUF al,REAL_MODE_BUFFER mov cx,1 ;cx = length call gvchars pcha_ret: xor ax,ax pop bp pop es ret printcha endp COMMENT % The two routines below are written such that they may run either on the hummingboard or out of 286/386 pritected memory. The hummingboard cannot directly address the host's physical memory, so when displaying escape chars within a string, it is first buffered into space allocated in the heap, then written via a block move to the print buffer. Although this is somewhat clumsy, it significantly improves performance over writing individual bytes to the print buffer with the BLOCK-MOVE dos function provided by OSx86. If in the future the hummingboard os traps instructions which are writing to real memory, then the buffering may be discarded and simple memory moves may be performed. % ;****************************************************************************** ;ATM2PBUF - Move symbol printname to printbuffer ; ; Description: ; The symbol name pointed to by ds:si is moved into a print buffer for output. ; ; If the display flag is set, the symbol is being output by the "write" lisp ; function and all backslashes and vertical bars (\,|) are written to the ; buffer preceeded by a backslash. In addition, the symbol must also be ; surrounded by vertical bars (|) if lowercase letters, commas, semi-colons, ; and other strange characters are encountered; or if the printname is a ; ".", a name starting with a # (other than special symbols), or is numeric. ; ; If the display flag is not set, then the printname is moved to the buffer ; without performing any translation. ; ; Upon Entry: ; cx = length of printname ; ds:si => printname ; es:di => print buffer ; ; Upon Exit: ; cx = # characters placed in print buffer ; es:di => print buffer ; ;****************************************************************************** p_struc struc dest_top dw ? dest_start dw ? heap_top dw ? heap_str dd ? src_start dw ? src_str dd ? dest_str dd ? stlen dw ? call_bp dw ? p_struc ends public atm2pbuf atm2pbuf proc near BUFFER_IS_BUFFER ;real mode buffer treated as such cmp ss:display,0 ;displaying escape chars? jnz a2p_xlat ; yes, jump ;move printname to print buffer MOVE_TO_REAL_BUF ;move entire string over ret ;return to caller a2p_err: mov [bp].stlen,-1 jmp a2p_fin ;move printname to print buffer, checking for backslashes and delimiters '|' a2p_xlat: push bp ;save callers bp push cx ;save length push es push di ;save real buffer address push ds push si ;save string address sub sp,src_str ;allocate local storage mov bp,sp mov [bp].src_start,si ;save start location of source string mov [bp].dest_start,di ;save print buffer start GET_REAL_BUFFER_TOP dx sub dx,pt_bfend+20 mov [bp].dest_top,dx ;save print buffer end mov ax,ss mov ds,ax mov es,ax ;setup for c call mov ax,512 push ax c_call getmem ;allocate 512 bytes of storage add sp,2 ;dump arg from stack cmp ax,0 ;allocation successful? jne a2p_write ; no, go write the buffer mov [bp].stlen,-1 ;indicate error jmp a2p_fin2 ; and exit a2p_write: mov [bp].heap_top,510 ;note top of heap buffer mov word ptr [bp].heap_str,ax ;save heap buffer address mov word ptr [bp].heap_str+2,es mov di,ax ;es:di = buffer mov byte ptr es:[di],'|' ;start buffer with escape char inc di ;di = address within buffer mov dx,1 ;dx = # chars written lds si,[bp].src_str ;ds:si addresses the string mov cx,[bp].stlen ;cx = char count xor bx,bx ;bh = strangeness cmp cx,0 ;char count zero? jne b2p_init ; no, jump or bh,080h ; yes, mark as strange jmp b2p_post ; and skip loop b2p_init: ;dx = #chars written, di=heap buffer offset, si=string offset, cx=char count b2plp: cmp dx,[bp].dest_top ;room left in buffer? jg a2p_err ; no, return error status lodsb ;fetch char from printname cmp al,'\' ;is char escape char? je escit ; yes, jump cmp al,'|' ;is char delimiter? jne storit ; no, just go store it escit: mov byte ptr es:[di],'\' ;write escape char to buffer inc di ;bump print buffer ptr inc dx ;bump # chars written storit: stosb ;write char to buffer inc dx ;bump # chars written test bh,80h ;do we already know that atom's strange? jnz skptest ; yes, skip following tests ;if lowercase letters or comma, semi-colon, etc. encountered, then it contains ;"strange" characters and must be delimited by '|' push si ;tempsave pname offset mov bl,al ;save copy of char in bl lea si,hicases ;si => table of upper cases xchg bx,si mov ah,al ;save char xlat ss:hicases ;fetch upper-case equivalent xchg bx,si cmp ah,al ;are chars different? jne mrkstrng ; yes, indicate strangeness mov si,offset stranges ;si => strange-character string strnglp: lods byte ptr ss:[si] ;fetch strange char or al,al ;finished searching for strange chars? jz notstrng ; yes, exit loop cmp ah,al ;Do we have a strange char? jne strnglp ; no, try next mrkstrng: or bh,80h ; yes, mark strange bit notstrng: pop si ;restore pname offset skptest: cmp di,[bp].heap_top ;heap buffer full? jl a2p_cont ; no, continue push cx ;save loop count mov word ptr [bp].src_str,si ;update string pointer sub di,word ptr [bp].heap_str ;calc number chars written mov cx,di ; and save in cx lds si,[bp].heap_str ;ds:si = heap buffer les di,[bp].dest_str ;es:di = real mode buffer MOVE_TO_REAL_BUF autoinc ;move string to print buffer add word ptr [bp].dest_str,di ;update next location in real buffer pop cx ;restore count lds si,[bp].src_str ;ds:si = pointer into string les di,[bp].heap_str ;es:di = heap allocated string ptr a2p_cont: loop b2plp ;look at next char in printname ; bh= strangeness, dx= #chars printed, di= end of printname ; write delimeter to heap allocated string, then copy to print buffer b2p_post: mov al,'|' ;follow with escape char stosb ;write to heap buffer inc dx ;bump character count sub di,word ptr [bp].heap_str ;calc number chars written mov cx,di ; and save in cx lds si,[bp].heap_str ;ds:si = heap buffer les di,[bp].dest_str ;es:di = real mode buffer MOVE_TO_REAL_BUF autoinc ;move string to print buffer mov [bp].stlen,dx ;save actual # chars written mov ds,word ptr [bp].src_str+2 mov si,[bp].src_start ;ds:si => start of source string test bh,80h ;do we already know atom's strange? jnz a2p_fin ; yes, jump ; Check for ., #macro, or numeric confusion cmp dx,3 ;a single char? (remember delimiters) jne a2p_sharp ; no, jump mov al,byte ptr ds:[si] ;get first byte of symbol cmp al,'.' ;do we have a period - "." ? je a2p_fin ; yes, delimits necessary a2p_sharp: cmp al,'#' ;macro designator? jne a2p_num ; no, jump cmp dx,3 ;a single sharp? (remember delimiters) je a2p_fin ; yes, delimits necessary cmp [bp].spg,SPECSYM*2 ;special symbol je a2p_nodelim ; yes, no delimeters required jne a2p_fin ; no, delimits necessary a2p_num: mov ax,10 ;check for number push ax ;base 10 push si ;ds:si => printname call scannum ;check for number add sp,4 ;dump args from stack test ax,ax ;is it a number? jnz a2p_fin ; yes, jump a2p_nodelim: ;although symbol being witten via "write", there are no stranges chars, ;or anything, so it can be written without delimiters. inc [bp].dest_start ;position past initial delimiter sub [bp].stlen,2 ;exclude delimeters from length a2p_fin: mov ax,ss mov ds,ax ;set up data segment mov es,ax ; and extra segment mov bx,512 ;length of heap buffer pushm C_call rlsmem, ;release character buffer add sp,4 ;dump args off stack a2p_fin2: mov es,word ptr [bp].dest_str+2 mov di,[bp].dest_start ;es:di => real buffer start mov cx,[bp].stlen ;cx = number characters written lds si,[bp].src_str ;restore ds:si add sp,call_bp ;dump args off stack pop bp ;restore base pointer ret atm2pbuf endp ;****************************************************************************** ;STR2PBUF - Move string to printbuffer ; ; Description: ; The print buffer is in real mode, the string is moved into the print ; buffer (possibly surrounded by quotes '"' and containing escape ; characters. ; ; Upon Entry: ; cx = length of string ; ds:si => string ; es:di => print buffer ; ; Upon Exit: ; cx = number of bytes written to print buffer ; es:di => print buffer ; ;****************************************************************************** public str2pbuf str2pbuf proc near BUFFER_IS_BUFFER ;real mode buffer treated as such cmp ss:display,0 ;display escape chars? jne s2p_xlat ; yes, jump ;move string to print buffer MOVE_TO_REAL_BUF ;move string to print buffer ret ;and return to caller ;move string to print buffer, inserting double quotes and escape chars s2p_xlat: push bp ;save callers bp push cx ;save length push es push di ;save real buffer address push ds push si ;save string address sub sp,src_str ;allocate local storage mov bp,sp mov [bp].dest_start,di ;save buffer start GET_REAL_BUFFER_TOP dx sub dx,pt_bfend+20 mov [bp].dest_top,dx ;save buffer end mov ax,ss mov ds,ax mov es,ax ;setup for c call mov ax,512 push ax c_call getmem ;allocate 512 bytes of storage add sp,2 ;dump arg from stack cmp ax,0 ;allocation successful? jne s2p_write ; no, go write the buffer mov cx,-1 ;indicate error jmp s2p_fin2 ; and exit s2p_write: mov [bp].heap_top,510 ;note top of heap buffer mov word ptr [bp].heap_str,ax ;save heap buffer address mov word ptr [bp].heap_str+2,es mov di,ax ;es:di = buffer mov byte ptr es:[di],'"' ;start buffer with escape char inc di ;di = address within buffer mov dx,1 ;dx = number chars written mov cx,[bp].stlen jcxz s2p_done ;jump if null string lds si,[bp].src_str ;ds:si addresses the string ;dx = #chars written, es:di=heap buffer offset, ds:si=string offset s2p_loop: cmp dx,[bp].dest_top ;room left in buffer? jg s2p_err ; no, return error status lodsb ;fetch char from string cmp al,'\' ;Is char escape char? je s2p_esc ; yes, jump cmp al,'"' ;Is char double quote? jne s2p_stor ; no, just go store it s2p_esc: mov ah,al mov al,'\' stosb ;store escape character inc dx ;bump # chars written xchg al,ah s2p_stor: stosb ;store escape character inc dx ;bump # chars written cmp di,[bp].heap_top ;heap buffer full? jl s2p_cont ; no, continue push cx ;save loop count mov word ptr [bp].src_str,si ;update string pointer sub di,word ptr [bp].heap_str ;calc number chars written mov cx,di ; and save in cx lds si,[bp].heap_str ;ds:si = heap buffer les di,[bp].dest_str ;es:di = real mode buffer MOVE_TO_REAL_BUF autoinc ;move string to print buffer add word ptr [bp].dest_str,di ;update next location in real buffer pop cx ;restore count lds si,[bp].src_str ;ds:si = pointer into string les di,[bp].heap_str ;es:di = heap allocated string ptr s2p_cont: loop s2p_loop ;look at next char in printname s2p_done: mov al,'"' ;follow with escape char stosb inc dx sub di,word ptr [bp].heap_str ;calc number chars written mov cx,di ; and save in cx lds si,[bp].heap_str ;ds:si = heap buffer les di,[bp].dest_str ;es:di = real mode buffer MOVE_TO_REAL_BUF autoinc ;move string to print buffer mov cx,dx ;cx = actual # chars written jmp s2p_fin ;finished s2p_err: mov cx,-1 ;indicate error s2p_fin: push cx ;save length around call mov bx,512 ;length of heap buffer pushm C_call rlsmem,,restore_es ;release character buffer add sp,4 ;dump args off stack pop cx s2p_fin2: lds si,[bp].src_str ;restore ds:si mov es,word ptr [bp].dest_str+2 mov di,[bp].dest_start ;es:di => real buffer start add sp,call_bp ;dump args off stack pop bp ;restore base pointer ret ;return str2pbuf endp prog ends end