Simtel MSDOS 1992 June

home *** CD-ROM | disk | FTP | other *** search

/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / ddjmag / ddj8908.arc / THOMAS.LST < prev

Wrap

File List | 1989-07-06 | 32.6 KB | 847 lines

SMALLTALK + C: THE POWER OF TWO by Dave Thomas and Randolph Best [LISTING ONE] Object subclass: #Dos instanceVariableNames: 'registers temp1 temp2 ' classVariableNames: '' poolDictionaries: '' ! !Dos methods ! doDCSPrimitive: opcode "PRIVATE - Call the DCS Primitives using an interrupt" <primitive: 96> getEnvironmentValue: anEnvironmentString "Private- This is a method for getting the value of an environment variable(string). Answers the value if anEnvironmentString is valid or nil if not found. Here the instance variables are used as follows: temp1 = the name of the environment variable wanted temp2 = the value of the environment, if the environment variable exists. " temp1 := anEnvironmentString asAsciiZ. temp2 := String new: 128. (self doDcsPrimitive: -11) ifTrue:[ ^temp2 trimBlanks ] ifFalse:[ ^''].! [LISTIN╟ TWO] ;***************************************************************************** ;ACCESS.USR - PRIMITIVE ENTRY MACRO - SMALLTALK/V ;Copyright (C) 1986 - Digitalk, Inc. - Reprinted by Permission ;***************************************************************************** ; It is essential that this macro appear at the beginning of ; the primitive in that it saves certain registers. Some of ; the registers may or may not have to be restored depending on ; whether or not the primitive is successful, and some ; must be restored before exiting the primitive. enterPrimitive MACRO ; At the end of this macro the stack will appear as below: ; SP--> BP--> - saved BP - must be restored on exit ; +2 - saved BX - must be restored in case of failure ; +4 - saved DI - must be restored in case of failure ; +6 - saved SI - must be restored on exit ; +8 - saved DS - must be restored on exit ; +10 - IP ; +12 - CS ; +14 - FLAGS ; if there are any argument passed to the primitive they are found here ; +16 - last argument to primitive ; +18 - second last argument to primitive ; - etc... ; high address - ; Note: some of the following macros use BP assuming the value has not ; changed from what this macro sets it to. If you use BP be sure ; to restore it before using the macros that make use of BP. PUSH DS ;set up stack as shown above PUSH SI PUSH DI PUSH BX PUSH BP MOV BP,SP ;set BP to Top of Stack ENDM ; This macro must be used when the primitive must be exited and the ; primitive was SUCCESSFUL. The resulting pointer or small integer ; must be in BX before invoking this macro. The macro will: ; - mark the object (pointer) in BX so that the garbage collector ; will not collect it as garbage ; - certain registers are restored ; - the return address and flags are popped into temporary registers ╗ ¡ thσ argument≤ arσ flusheΣ anΣ replaceΣ witΦ thσ resul⌠ iε BX ; - the return address and flags are put back on the stack ; - AX is set to zero (AH=0 indicates that the primitive was successful) ; - and the IRET instruction is executed exitWithSuccess MACRO numOfArgs ; On entry BX must contains the result to be pushed ; on the stack. è markPtr BX,ES ;mark result object in BX POP BP ;restore BP ADD SP,4 POP SI ;restore DS:SI pair POP DS POP CX ;pop the offset,segment and POP DX ;flags into temp registers POP AX IF numOfArgs ADD SP,numOfArgs * 2 + 2 ;flush all args of primitive ENDIF PUSH BX ;push result on stack PUSH AX ;push flags, segment and PUSH DX ;offset back onto stack PUSH CX XOR AX,AX ;AH to 0 (prim was successful) IRET ;interrupt return ENDM ; This macro must be used when the primitive must be exited and the ; primitive FAILED. The macro will: ; - restore all saved registers ; - set AH to 1 indicating failure condition and AL to the number ; of arguments passed to the primitive ; - and the IRET instruction is executed exitWithFailure MACRO numOfArgs POP BP ;restore all saved registers POP BX POP DI POP SI POP DS MOV AX,256 + numOfArgs ;AH to 1 (prim failed) IRET ;interrupt return ENDM ; This macro will return the address of the object with object pointer ; in objectReg. The address will be returned in the register pair ; segmentReg:offsetReg. segmentReg must be a segment register. getObjectAddress MACRO objectReg,offsetReg,segmentReg ; All the arguments must be different registers. ; BP must not have changed from the value it was ; set to in the enterPrimitive macro. MOV segmentReg,[BP+12] ROR objectReg,1 MOV offsetReg,segmentReg:[objectReg] ROL objectReg,1 MOV segmentReg,SS:[objectReg] AND offsetReg,MASK offsetMask ENDM è ; This macro will mark the object whose object pointer is in objectReg ; so the garbage collector will not collect as garbage. It is to be used ; whenever an object pointer is stored. If the object in objectReg is ; a small integer, no marking occurs. markPtr MACRO objectReg,segmentReg LOCAL done ; BP must not have changed from the value it was ; set to in the enterPrimitive macro. ROR objectReg,1 JNC done MOV segmentReg,[BP+12] OR BYTE PTR segmentReg:[objectReg],MASK grayMask done: ROL objectReg,1 ENDM ; This macro will get the class (pointer) of the object whose pointer ; is in objectReg. If the object in objectReg is a small integer then ; the class pointer is set to ClassSmallInt. getClass MACRO objectReg,classReg,segmentReg LOCAL done ;all the arguments must be different registers MOV classReg,ClassSmallInt TEST objectReg,1 JZ done MOV classReg,SS SHR classReg,1 MOV segmentReg,classReg MOV classReg,segmentReg:[objectReg] done: ENDM ; This macro will set the zero condition flag as to whether the object size ; is an even or odd number of bytes. This test should be performed on ; byte-addressable objects. A zero condition means that the object is an ; even number of bytes (actual size = object header - 2). A non-zero ; condition means that the object is an odd number of bytes ; (actual size = object header - 3). isSizeEven MACRO objectReg,workReg,segmentReg ; BP must not have changed from the value it was ; set to in the enterPrimitive macro. MOV workReg,objectReg ROR objectReg,1 MOV segmentReg,[BP+12] TEST BYTE PTR segmentReg:[objectReg],MASK oddMask MOV objectReg,workReg è ENDM ;***************************************************************************** ; PRIMITIVE ENTRY POINT SAMPLE CODE FRAGMENTS ;***************************************************************************** DW getCountryEnt DW getEnvironEnt DW exeApplicEnt DW exeProgramEnt DW setNoXlatEnt DW setXlatEnt DW atEndEnt DW bufFlushEnt DW bufWriteEnt DW bufReadEnt DW initOutputEnt DW initInputEnt jumpTable DW interruptEnt DW inWordEnt DW inByteEnt DW outWordEnt DW outByteEnt DW peekEnt DW pokeEnt DW blockMoveEnt * * * dcsPrims proc far ; This is code that will be executed everytime this primitive ; is invoked from "Smalltalk/V" enterPrimitive ;enter primitive macro mov bx,[bp+16] ;get function code from first instance test bl,1 ; variable of receiving object. if it jnz failure ; isn't a number then something's very ; rotten in the state of Denmark. cmp bx,16 ;the function code is already shifted jge failure ; left by one (courtesy of smalltalk's cmp bx,-26 ; way of identifying integers), so do jle failure ; some range checks and abort if the ; value is out of bounds. jmp cs:[bx+jumpTable] ;otherwise, jump to the code associated ; with this function number. * * * è mov cs:stackOfs,sp ;save the current Smalltalk stack, and mov cs:stackSeg,ss ; replace it with a local stack in low mov ax,cs ; (protected memory). cli mov ss,ax lea sp,cs:_stack sti mov ah,2fh ;save the DOS DTA pointer, just in case int 21h ; it gets clobbered by the application. mov cs:dtaOfs,bx mov cs:dtaSeg,es call exec ;load and execute the program mov bx,truePtr ; the errorlevel jnc exec01 ; code is returned in "retCode". If the mov bx,falsePtr ; carry was set, then an error occurred exec01: mov retVal,bx ; and we answer "false", otherwise we ; answer "true". mov ah,1ah ;restore the DOS DTA pointer. lds dx,cs:dtaPtr int 21h cli ;and, restore the Smalltalk stack with mov ss,cs:stackseg ; the saved pointer. mov sp,cs:stackofs sti mov ax,retCode ;convert the errorlevel to a Smalltalk shl ax,1 ; integer format, and return it in the les bx,receiverPtr ; fifth instance variable of receiver mov es:[bx+12],ax ; object. mov bx,retVal ;the Smalltalk convention is to put the jmp success1 ; answer for this obj in bx, and call ; the "leavePrimitive" macro. a jump ; to success will do this quite nicely ; thank yew! [LISTIN╟ THREE] ;queue an interpreter interrupt (in protected mode) ; AL=interrupt number to queue interruptVM MACRO CALL DWORD PTR SS:[queueVMinterrupt] ENDM ;queue an interpreter interrupt (in real mode) ISVinterruptVM MACRO MOV ES,CS:[realParmSeg] CALL DWORD PTR ES:[ISVqueueVMinterrupt] ENDM The code to call the socket primitive in Smalltalk is: socketPrimitiveOpcode: opcode withArguments: argumentArray "PRIVATE: Call the socket primitive." <primitive: socketPrimitive> ^self error: 'Network Primitive failed - is sockprim.bin loaded?' [LISTIN╟ FOUR] ;***************************************************************************** ;* FIXDPTRS.USR ;***************************************************************************** ;fixed segments plusSmallSeg = 6 ;segment of small positive integers nilSegment = 106H ;segment of nil object minusSmallSeg = 116H ;segment of small negative integers booleanSeg = 10EH ;segment for true and false characterSeg = 11EH ;segment for all character objects fixedPtrSeg = 126H ;segment for all fixed ptr objects ;fixed offsets nilOffset = 106H ;offset of nil object trueOffset = 0fff3H ;offset of true object falseOffset = 0fff1H ;offset of false object firstCharOffset = 2 ;offset of ascii char 0 ;all of the following objects are in the segment fixedPtrSeg ;what is given below are their offsets ;array of classes in system classArrayOffset equ nilOffset+size objectHeader Smalltalk equ classArrayOffset + size assoc ErrorCode equ Smalltalk + size assoc ;***************************************************************************** ; OBJECTS.USR ;***************************************************************************** ;Object header structure objectHeader STRUC ClassPtrHash DW ? ;see below for values for fixed classes èObjectPtrHash DW ? ;usually contains object hash GCreserved DW ? NumberFixed DW ? ;number of named instance variables ObjectSize DB 3 DUP(?) ;stored as low,middle,high order ; size is stored as # of instance variables ObjectFlags DB ? ;defined below objectHeader ENDS ;object flags (contained in objectFlag byte of objectHeader) PointerBit EQU 10H ;Object contains pointers IndexedBit EQU 8 ;Object has indexed instance variables ;other bits in byte are reserved ;Array Object arrayObj STRUC DB size objectHeader DUP (?) arrayObj ENDS ;Character Object charObj STRUC DB size objectHeader DUP (?) asciiValue DD ? ;ascii value charObj ENDS ;Note that this is 16 bytes in size ; Association Object assoc STRUC DB size objectHeader DUP (?) assocKey DD ? assocValue DD ? assoc ENDS ; Point object pointObj STRUC DB size objectHeader DUP (?) pointX DD ? pointY DD ? pointObj ENDS ; Hash values for classes SmallIntegerHash equ 0 emptySlotHash equ SmallIntegerHash + 8 StringHash equ emptySlotHash + 8 MessageHash equ StringHash + 8 SymbolClassHash equ MessageHash + 8 LargePosIntHash equ SymbolClassHash + 8 HomeContextHash equ LargePosIntHash + 8 LargeNegIntHash equ HomeContextHash + 8 ContextHash equ LargeNegIntHash + 8 PointHash equ ContextHash + 8 ArrayHash equ PointHash + 8 LinkHash equ ArrayHash + 8 ; This is a useful struc for accessing arguments in primitives ; For example, to load the receiver into DS:SI è; LDS SI,[BP+receiverPtr] ;stack after enterPrimitive macro primitiveFrame STRUC savedBP DW ? returnAddr DD ? receiverPtr DD ? arg1Ptr DD ? arg2Ptr DD ? arg3Ptr DD ? primitiveFrame ENDS ;This struc defines the beginning of a user primitive load module primLoadModule STRUC installEntry DW ? ; 0 entry point for installation routine reserved1 DW 0 ; 2 DW 0 ; 4 realCodeSeg DW ? ; 6 after loading, will contain real mode addr primTableOffset DW ? ; 8 offset of table of primitive subroutines realParmSeg DW ? ; A after loading, will contain real mode addr ; of virtual machine communication area. reserved2 DW 0 ; C DW 0 ; E primLoadModule ENDS ;***************************************************************************** ;* ACCESS.USR -PRIMITIVE ENTRY MACRO - SMALLTALK/V286 ;* Copyright (C) 1988 - Digitalk, Inc. - Reprinted by Permission ;***************************************************************************** ; It is essential that this macro appear at the beginning of ; the primitive in that it saves certain registers. Some of ; the registers may or may not have to be restored depending on ; whether or not the primitive is successful, and some ; must be restored before exiting the primitive. enterPrimitive MACRO ; At the end of this macro the stack will appear as below: ; ; SP--> BP--> - saved BP ; +2 - return addr (offset) ; +4 - return addr (segment) ; If there are any argument passed to the primitive they are found here. ; All arguments and the receiver are passed as 32 bit pointers ; +6 - receiver of primitive (offset) ; +8 - receiver of primitive (segment) ; +10 - first argument to primitive (offset) ; +12 - first argument to primitive (segment) ; - : ; high address - : ; ; Note: some of the following macros use BP assuming the value has not ; changed from what this macro sets it to. If you use BP be sure ; to restore it before using the macros that make use of BP. è PUSH BP ;save old BP MOV BP,SP ;set BP to Top of Stack ENDM ; This macro must be used when the primitive must be exited and the ; primitive was SUCCESSFUL. The resulting pointer or small integer ; must be in DX,AX (DX=segment, AX=offset) before invoking this macro. exitWithSuccess MACRO ; On entry DX,AX must contains the result to be pushed ; on the stack. MOV SP,BP POP BP ;restore BP RETF ;far return ENDM ; This macro must be used when the primitive must be exited and the ; primitive FAILED. exitWithFailure MACRO XOR AX,AX ;AX=DX=0, for failure return XOR DX,DX MOV SP,BP POP BP ;restore BP RETF ;far return ENDM ;Object testing macros ; ;in the following testing macros, ;the result is returned in the zero flag as follows: z=no, nz=yes ;Object has pointers?? jz=no, jnz=yes isPointerObject MACRO objSeg,objOff TEST objSeg:[objOff+objectFlags],PointerBit ENDM ;Object is indexable?? jz=no, jnz=yes isIndexedObject MACRO objSeg,objOff TEST objSeg:[objOff+objectFlags],IndexedBit ENDM ;Object is contained in single segment?? jz=no, jnz=yes isSmallObject MACRO objSeg,objOff OR objOff,objOff ENDM ;**** size extraction macros **** ;Object size is expressable in elements or bytes. ; elements is the number of smalltalk objects it contains ; bytes is the number of bytes it occupies (including header) è; note that objects always occupy an even number of bytes ;For example: ; #( 1 2 3 ) is an array with three element≤ and it occupies 24 bytes ; 'hello' is a string with 5 element≤ and it occupies 18 bytes ;extract the size in elements getElementSize MACRO objSeg,objOff,resultLowWord,resultHighByte MOV resultHighByte,byte ptr objSeg:[objOff+objectSize+2] MOV resultLowWord,word ptr objSeg:[objOff+objectSize] ENDM ;compute the size in bytes getBigByteSize MACRO objSeg,objOff,resultLowWord,resultHighByte LOCAL addHeader getElementSize objSeg,objOff,resultLowWord,resultHighByte isPointerObject objSeg,objOff JZ addHeader ADD resultLowWord,resultLowWord ADC resultHighByte,resultHighByte ADD resultLowWord,resultLowWord ADC resultHighByte,resultHighByte addHeader: ADD resultLowWord,size objectHeader+1 ADC resultHighByte,0 AND resultLowWord,0FFFEH ENDM ;user calls to interpreter routines ;routine vector offsets ISVqueueVMinterrupt equ 0FFF0H - 4 queueVMInterrupt equ ISVqueueVMinterrupt-4 oldToNewStore equ queueVMinterrupt-4 ;used in oldToNewUpdate macro ;queue an interpreter interrupt (in protected mode) ; AL=interrupt number to queue interruptVM MACRO CALL DWORD PTR SS:[queueVMinterrupt] ENDM ;queue an interpreter interrupt (in real mode) ISVinterruptVM MACRO MOV ES,CS:[realParmSeg] CALL DWORD PTR ES:[ISVqueueVMinterrupt] ENDM ;miscellaneous but usefull macros ;is object a small positive integer -- je=yes, jne=no ;(only segment needs to be tested) isSmallPosInt MACRO segmentExpression CMP segmentExpression,plusSmallSeg ENDM ;is object a small negative integer -- je=yes, jne=no ;(only segment needs to be tested) èisSmallNegInt MACRO segmentExpression CMP segmentExpression,minusSmallSeg ENDM ;is object a character -- je=yes, jne=no ;(only segment needs to be tested) isCharacter MACRO segmentExpression CMP segmentExpression,characterSeg ENDM ;is object static, i.e. constant, no stores allowed -- ja=no, jbe=yes ;(only segment needs to be tested) isStaticObject MACRO segmentExpression CMP segmentExpression,characterSeg ENDM ;****** This macro must be called after EVERY pointer store ******* ;****** Failure to do so will invalidate the garbage collector **** ;****** leading to catastrophic and unpredicable results ********** ;This macro detects old space to new space pointer stores, ;and updates the GC data base accordingly. ; ;macro arguments are as follows: ; segReg = seg reg of object stored into ; offReg = offset reg of object stored into ; valueSeg = segment of pointer that was stored ; workReg = a work register ; ;example of use: store ptr BX:AX into object ES:DI at slot 'contents' ; MOV word ptr es:[di+contents],AX ;store offset ; MOV word ptr es:[di+contents+2],BX ;store segment ; OldToNewUpdate es,di,bx,ax OldToNewUpdate macro segReg,offReg,valueSeg,workReg LOCAL done MOV workReg,segReg CMP workReg,92EH JAE done CMP valueSeg,92EH JB done PUSH segReg PUSH offReg CALL DWORD PTR SS:[oldToNewStore] POP offReg POP segReg done: ENDM ;**************************************************************************** ; SOCKPRIM.ASM ; The V286 Socket Primitives V2.0 ; In this implementation, recv() and accept() only operate in ; a nonblocking fashion, returning errno EWOULDBLOCK if the ; operation can not be completed immediately. All other calls ; block until completion or error. è; Opcode 0 is implemented in this version as Socket closeAll. ; Opcode 18 is implemented in this version as Socket version. ; An additional non-standard errno EDRIVER (254) is returned if ; installation fails or the installed driver behaves strangely. ;**************************************************************************** ; TITLE Socket Primitives .286P INCLUDE fixdptrs.usr INCLUDE objects.usr INCLUDE access.usr INCLUDE sockprim.inc code SEGMENT PUBLIC 'CODE' ASSUME CS:code,DS:nothing,ES:nothing PGROUP GROUP CODE ;**************************************************************************** ; Smalltalk/V286 Reserved Area ;**************************************************************************** ; ORG 0 DW OFFSET install ;installation routine entry point DW 0 ;reserved for future use DW 0 DW 0 ;real mode segment of this code DW OFFSET primTable ;addr of table of primitives and entry points DW 0 ;real mode segment address of protected mode ;parameter area DW 0 ;cell used for real mode calls to VM DW 0 ;**************************************************************************** ; Local Data ;**************************************************************************** ; initialized_flag DW 0 Socket_PB DB 32 DUP (0) Name_Buffer DB MAX_NAME_SIZE DUP (0) Data_Buffer DB MAX_BUFFER_SIZE DUP (0) ;**************************************************************************** ; The socketPrimitive operation dispatcher ;**************************************************************************** ; socketPrimitive PROC FAR ; ; Dispatch the socket primitive specified by opcode. ; PARAM(1) is the opcode ; PARAM(2) is the argumentArray è; enterPrimitive isSmallPosInt <WORD PTR [BP+arg1ptr+2]> ;opcode SmallInteger? JE ok_opcode FAIL ;FAIL if not ok_opcode: MOV AX,initialized_flag ;perform initialization OR AX,AX JNE initialized PUSH BP CALL socket_install POP BP CMP AX,0 JE initialized SUCCEED_ERROR initialized: MOV AX, WORD PTR [BP+arg1ptr] ;opcode ; ; check opcode bounds ; CMP AX,0 JL exit_FAIL CMP AX,MAX_OPCODE JG exit_FAIL SHL AX,1 MOV SI,AX ; ; dispatch operation ; MOV AX,WORD PTR DS:[Socket_Primitives+SI] JMP AX SUCCEED_POSITIVE_INTEGER exit_FAIL: FAIL socketPrimitive ENDP ;**************************************************************************** ; The socket event handler - called by resident driver in real mode ;**************************************************************************** ; socket_event_handler PROC FAR MOV AX,Network_VMInterrupt ISVinterruptVM RET socket_event_handler ENDP ;**************************************************************************** ; General purpose success exit ; AX = integer value to be returned (positive or negative) ;**************************************************************************** ; ;SUCCEED_INTEGER PROC NEAR ; CMP AX,0 è; JL SUCCEED_NEGATIVE ; SUCCEED_POSITIVE_INTEGER ;SUCCEED_NEGATIVE: ; SUCCEED_NEGATIVE_INTEGER ;SUCCEED_INTEGER ENDP ;**************************************************************************** ; Install Socket Event Handler - called automatically by dispatch ;**************************************************************************** ; socket_install PROC NEAR MOV AX,1 MOV SI,OFFSET initialized_flag MOV DS:[SI],AX ; SET_PB_FOR OPCODE_register_event_handler MOV WORD PTR DS:PB_Event_Handler[BX],OFFSET socket_event_handler MOV AX,DS:[realCodeSeg] MOV WORD PTR DS:PB_Event_Handler+2[BX],AX ; MOV BYTE PTR DS:PB_errno[BX],EDRIVER MOV WORD PTR DS:PB_Return_Code[BX],-1 ; CALL_NETWORK RET socket_install ENDP ;**************************************************************************** ; The socket operations ;**************************************************************************** op_unimplemented PROC NEAR MOV AX,EINVAL SET_errno SUCCEED_ERROR op_unimplemented ENDP op_closeAll PROC NEAR SET_PB_FOR OPCODE_socket_close_all ; CALL_NETWORK SUCCEED_INTEGER op_closeAll ENDP ;**************************************************************************** ; deinstall() - perform required cleanup before Smalltalk/V exit ;**************************************************************************** ; op_deinstall PROC NEAR MOV AX,0 MOV SI,OFFSET initialized_flag MOV DS:[SI],AX ; SET_PB_FOR OPCODE_register_event_handler MOV WORD PTR DS:PB_Event_Handler[BX],0 è MOV WORD PTR DS:PB_Event_Handler+2[BX],0 ; CALL_NETWORK SUCCEED_INTEGER op_deinstall ENDP ;**************************************************************************** ; socket() ; ARG 1 Address_Format ; ARG 2 Type ; ARG 3 Protocol ;**************************************************************************** ; op_socket PROC NEAR SET_PB_FOR OPCODE_socket ; GET_POSITIVE_INTEGER_ARG 1 MOV DS:PB_Address_Format[BX],AX ; GET_POSITIVE_INTEGER_ARG 2 MOV DS:PB_Type[BX],AX ; GET_POSITIVE_INTEGER_ARG 3 MOV DS:PB_Protocol[BX],AX ; CALL_NETWORK ;sets errno, result in AX SUCCEED_INTEGER op_socket ENDP * * * ;================================================================= ; doEthernetInt ; This procedure executes in REAL MODE. The parameter block has ; been filled. setup es:bx to point to the parameter block and ; call the ethernet driver. doEthernetInt PROC FAR PUSH AX ; Save registers PUSH BX ; PUSH ES ; MOV AX,CS ; MOV ES,AX ; es points to this segment MOV BX, OFFSET Socket_PB ; bx contains offset to pblock INT Resident_Driver_Interrupt ; call driver POP ES ; restore registers POP BX ; POP AX ; RET doEthernetInt ENDP ;table of primitive names and entry points primTable: è DB 'socketPrimitive' ;Smalltalk name of primitive DB 0 DW offset socketPrimitive ;offset of entry point ; ; more entries can go here DW 0 ;end of table ;installation routine, called at the time the module is loaded install PROC FAR ret ;we have nothing to do, so return install endp code ENDS END