www.pudn.com > tp60src.zip > CONVERT2.ASM
model large compiler_text,pascal include compiler.inc .code compiler_text public GetReturnVar public Store public PutCall public ReturnValue public DiscardReturn public TypeCompat public ProcCompat public CastOrdinal public CastByte public CastInt public CastWord public CastLong GetReturnVar proc near les si,CurrentSymbol mov ax,es cmp ax,Dictionary.Segm jne @@2 cmp es:[si].psType.ptResult.Offs,0 je @@2 mov bx,es:[si].psProcMap push ds mov ds,ProcMap.Segm cmp [bx].pmCodeMap,-2 pop ds jne @@2 xor ax,ax mov bx,es:[si].psType.ptResult.Offs mov si,es:[si].psType.ptResult.Segm mov es,es:[si] sub ax,es:[bx].tdSizeOf cmp es:[bx].tdType,ttString jne @@1 push es di bx les di,CurrentSymbol Invoke StackRequired pop bx di es mov ax,dx @@1: clc ret @@2: stc ret GetReturnVar endp Store proc near les bx,[di].exType mov bl,es:[bx].tdType xor bh,bh shl bx,1 jmp cs:@@1[bx] @@1 dw StoreCompound dw StoreCompound dw StoreCompound dw StoreObject dw StoreCompound dw StoreCompound dw StoreOrdinal dw StoreSet dw StoreOrdinal dw StoreString dw Store8087 dw StoreReal dw StoreOrdinal dw StoreOrdinal dw StoreOrdinal dw StoreOrdinal Store endp StoreObject proc near les bx,[di].exType mov ax,_CopyObject mov dx,es:[bx].otVMTOffset cmp es:[bx].otVMTSize,0 jne @@1 StoreCompound label near xchg si,di call ShortRecord xchg si,di call ShortRecord jz StoreOrdinal les bx,[di].exType mov ax,_BlockMove mov dx,es:[bx].tdSizeOf @@1: push ax dx xchg si,di Invoke Push2Addrs Invoke Use2Exprs xchg si,di pop ax Invoke PushWord pop ax Invoke PutSystemCall Chain DoneExpr StoreObject endp StoreOrdinal proc near cmp [si].exLocation,elImmediate jne @@4 mov ax,[si].exValue.W0 or ax,[si].exValue.W2 jnz @@2 test [di].exModifier,emX jz @@2 Invoke UseExpr mov ax,0c031h ; xor ax,ax Invoke PutWord mov al,lvAX Invoke StoreReg test [di].exModifier,emXX jz @@1 add [di].exOffset,2 mov al,lvAX Invoke StoreReg sub [di].exOffset,2 @@1: or [di].exRegsUsed,erAX Chain DoneExpr @@2: Invoke UseExpr mov ax,[si].exValue.W0 Invoke PutMovRMImm test [di].exModifier,emXX jz @@3 add [di].exOffset,2 mov ax,[si].exValue.W2 Invoke PutMovRMImm sub [di].exOffset,2 @@3: Chain DoneExpr @@4: xchg si,di Invoke UseExpr mov al,[si].exRegsUsed Invoke FindEmptyReg xchg si,di Invoke UseExpr xchg si,di xor al,al Invoke PopValue xchg si,di mov al,[si].exMisc Invoke StoreValue Chain DoneExpr StoreOrdinal endp StoreSet proc near xchg si,di Invoke _LoadSet Invoke Push2Addrs Invoke Use2Exprs xchg si,di les bx,[di].exType Invoke PushSetAddr mov ax,_ZStore Invoke PutSystemCall Chain DoneExpr StoreSet endp StoreString proc near cmp [si].exLocation,elImmediate jne @@1 mov bx,[si].exOffset cmp [bx].B0,0 jne @@1 Invoke UseExpr mov dx,0c6h ; mov [...],0 Invoke AddReg xor al,al Invoke PutByte Chain DoneExpr @@1: xchg si,di Invoke PutImmedString Invoke Push2Addrs Invoke Use2Exprs xchg si,di les bx,[di].exType mov ax,es:[bx].tdSizeOf dec ax Invoke PushWord mov ax,_SStore Invoke PutSystemCall Chain DoneExpr StoreString endp Store8087 proc near xchg si,di Invoke PushExt Invoke Use2Exprs xchg si,di mov dx,18d9h ; fstp test [di].exModifier,emExtended jz @@1 mov dh,38h @@1: or dl,[di].exModifier Invoke PutFloatRM Invoke PutFwait Chain DoneExpr Store8087 endp StoreReal proc near cmp [si].exLocation,elImmediate jne @@1 Invoke UseExpr mov ax,[si].exValue.W0 Invoke PutMovRMImm add [di].exOffset,2 mov ax,[si].exValue.W2 Invoke PutMovRMImm add [di].exOffset,2 mov ax,[si].exValue.W4 Invoke PutMovRMImm jmp short @@4 @@1: xchg si,di Invoke UseExpr mov al,lrR1 Invoke LoadReal xchg si,di cmp [di].exRegsUsed,0 je @@2 mov ax,5352h ; push dx push bx Invoke PutWord mov al,50h ; push ax Invoke PutByte @@2: Invoke UseExpr cmp [di].exRegsUsed,0 je @@3 mov al,58h ; pop ax Invoke PutByte mov ax,5a5bh ; pop bx pop dx Invoke PutWord @@3: mov al,lvAX Invoke StoreReg add [di].exOffset,2 mov al,lvBX Invoke StoreReg add [di].exOffset,2 mov al,lvDX Invoke StoreReg @@4: sub [di].exOffset,4 Chain DoneExpr StoreReal endp ShortRecord proc near les bx,[di].exType mov ax,es:[bx].tdSizeOf cmp ax,1 je @@1 cmp ax,2 je @@2 cmp ax,4 je @@3 ret @@1: mov [di].exModifier,0 ret @@2: mov [di].exModifier,emX ret @@3: mov [di].exModifier,emX+emXX ret ShortRecord endp PutCall proc near cmp [di].exLocation,elMemory je @@2 test [di].exModifier,emNotVirtual jnz @@3 les bx,[di].exType cmp es:[bx-psType].psOwner,0 je @@3 call GetActualParams les si,[di].exType call HiddenParams and [di].exMisc,efDS+efSS+efCS or [di].exMisc,efES Invoke PutPrefix mov si,es:[si-psType].psScope mov ax,es:[si].otVMTOffset mov dx,3d8bh ; mov di,[di+...] Invoke AddOffset test CompilerOptions,coRangeChk jz @@1 mov ax,_MethodCheck Invoke PutSystemCall @@1: les si,[di].exType mov ax,es:[si-psType].psOwner mov dx,1dffh ; call [di+...] Invoke AddOffset Chain DoneExpr @@2: call GetActualParams Invoke UseExpr mov dx,18ffh ; call [...] Invoke AddReg Chain DoneExpr @@3: call GetActualParams mov bx,si les si,[di].exType test es:[si-psType].psFlags,pfInterrupt jnz @@4 test es:[si-psType].psFlags,pfInline jz @@5 mov cx,es:[si-psType].psInlineLen push di mov di,bx Invoke PutInline pop di jmp short @@11 @@4: mov ax,114 Chain CompileError @@5: test es:[si-psType].psFlags,pfMethod jz @@6 call HiddenParams jmp short @@8 @@6: mov dx,es:[si-psType].psScope or dx,dx jz @@8 cmp dx,CurScope jne @@7 mov al,55h ; push bp Invoke PutByte jmp short @@8 @@7: mov cx,76ffh ; push [bp+...] Invoke GetNestedRef @@8: test es:[si-psType].psFlags,pfFar jz @@10 mov ax,es cmp ax,Dictionary.Segm je @@9 mov al,9ah ; call Invoke PutByte mov ax,es mov bx,es:[si-psType].psProcMap mov cx,ffProc+ffPtr xor dx,dx Invoke PutFixup jmp short @@11 @@9: mov al,0eh ; push cs Invoke PutByte @@10: mov al,0e8h ; call Invoke PutByte mov ax,es mov bx,es:[si-psType].psProcMap mov cx,ffProc xor dx,dx Invoke PutFixup @@11: Chain DoneExpr PutCall endp HiddenParams proc near test es:[si-psType].psFlags,pfConstructor jz @@1 test [di].exModifier,emNotVirtual jnz @@2 push es mov al,0b8h ; mov ax, Invoke PutByte les bx,[di].exOwner mov ax,es mov bx,es:[bx].otVMTAddr mov cx,ffConst+ffOffs xor dx,dx Invoke PutFixup pop es jmp short @@4 @@1: test es:[si-psType].psFlags,pfDestructor jz @@5 mov ax,0ffb0h ; mov al,0ffh test [di].exModifier,emDisposeDestr jnz @@3 @@2: mov ax,0c031h ; xor ax,ax @@3: Invoke PutWord @@4: mov al,50h ; push ax Invoke PutByte @@5: test [di].exModifier,emNotVirtual jnz @@7 test [di].exModifier,emNewConstruct jnz @@6 Invoke UseExpr Invoke LoadSegDI or al,6 mov ah,57h ; push ?s push di Chain PutWord @@6: mov ax,0c031h ; xor ax,ax Invoke PutWord mov ax,5050h ; push ax push ax Chain PutWord @@7: push es si Invoke GetTopScope jz @@8 mov bx,es:[si].psScope mov ax,[di].exOwner.Offs mov dx,[di].exOwner.Segm Invoke CheckInherit jnz @@8 pop si es mov cx,7ec4h ; les di,[bp+...] xor dx,dx Invoke GetNestedRef mov [di].exMisc,efES+efDI mov [di].exOffset,0 mov ax,5706h ; push es push di Chain PutWord @@8: mov ax,143 Chain CompileError HiddenParams endp ReturnValue proc near les bx,[di].exType mov si,es:[bx].ptResult.Segm mov bx,es:[bx].ptResult.Offs mov es,es:[si] mov [di].exType.Offs,bx mov [di].exType.Segm,es mov [di].exRegsUsed,erAll cmp es:[bx].tdType,ttInteger jae @@1 cmp es:[bx].tdType,ttPointer je @@1 cmp es:[bx].tdType,ttReal jne @@2 @@1: mov al,es:[bx].tdModifier mov [di].exLocation,elRegister mov [di].exModifier,al mov [di].exMisc,lvAX ret @@2: cmp es:[bx].tdType,tt8087 jne @@3 mov [di].exLocation,elStack mov [di].exModifier,emExtended ret @@3: mov ax,256 Invoke CreateLocalVar Invoke UseExpr Chain DoneExpr ReturnValue endp DiscardReturn proc near les bx,[di].exType cmp es:[bx].tdType,ttString je @@1 cmp es:[bx].tdType,tt8087 je @@2 ret @@1: Invoke UseExpr mov ax,0c483h ; add sp,4 Invoke PutWord mov al,4 Invoke PutByte Chain DoneExpr @@2: Invoke UseExpr Invoke PutEmulInt mov ax,0d835h ; fstp st(0) Invoke PutWord Chain DoneExpr DiscardReturn endp GetActualParams proc near Loc ParamType,dword,1 Loc Param,byte,Loc Buffer,word,64 Entry les si,[di].exType mov cx,es:[si].ptParamCount add si,ptParams jcxz @@3 mov Buffer[0],0 mov al,tOParen Invoke NeedToken push di @@1: push cx si es call GetActualParam pop es si cx add si,size TProcParam dec cx jz @@2 mov al,tComma Invoke NeedToken jmp @@1 @@2: pop di mov al,tCParen Invoke NeedToken lea bx,Buffer Invoke FlushGoals @@3: Exit GetActualParam proc near mov al,es:[si].ppFlags mov bx,es:[si].ppType.Segm mov si,es:[si].ppType.Offs mov es,es:[bx] mov ParamType.offs,si mov ParamType.segm,es lea di,Param test al,vfAddress jnz @@6 lea si,ParamType Invoke GetExpression lea si,ParamType Invoke AssignmentCast call TypeCompat call CastOrdinal les bx,[di].exType mov al,es:[bx].tdType cmp al,ttInteger jae @@1 cmp al,ttPointer je @@1 cmp al,ttProc je @@1 cmp al,ttSet je @@2 cmp al,ttString je @@3 cmp al,tt8087 je @@4 cmp al,ttReal je @@5 call ShortRecord jnz @@10 @@1: Invoke PushValue jmp short @@11 @@2: Invoke _LoadSet call NeedCopyParam jz @@10 Invoke LoadSet jmp short @@10 @@3: Invoke PutImmedString call NeedCopyParam jz @@10 Invoke _LoadString jmp short @@10 @@4: Invoke PushFloat jmp short @@11 @@5: Invoke PushReal jmp short @@11 @@6: Invoke GetReference les bx,ParamType mov al,es:[bx].tdType cmp al,ttVoid je @@10 cmp al,ttString je @@7 cmp al,ttObject jne @@9 mov ax,bx mov dx,es les bx,[di].exType Invoke CheckInherit jz @@10 jmp short @@8 @@7: test CompilerOptions,coVarStringChk jnz @@9 les bx,[di].exType cmp es:[bx].tdType,ttString je @@10 @@8: mov ax,26 Chain CompileError @@9: cmp bx,[di].exType.Offs jne @@8 mov ax,es cmp ax,[di].exType.Segm jnz @@8 @@10: Invoke PushAddr @@11: mov ax,[di].exCode lea bx,Buffer Chain AddGoal GetActualParam endp GetActualParams endp NeedCopyParam proc near test CompilerOptions,coOverlayCode jz @@1 cmp [di].exLocation,elStack je @@1 test [di].exMisc,efCS @@1: ret NeedCopyParam endp TypeCompat proc near les bx,[di].exType mov al,es:[bx].tdType les bx,[si].exType cmp al,es:[bx].tdType jne @@1 mov bl,al xor bh,bh shl bx,1 call cs:@@2[bx] jnz @@1 ret @@1: mov ax,26 Chain CompileError @@2 dw StrictCompat dw StrictCompat dw StrictCompat dw StrictCompat dw StrictCompat dw StrictCompat dw ProcCompat dw SetCompat dw PointerCompat dw AnyCompat dw AnyCompat dw AnyCompat dw AnyCompat dw AnyCompat dw AnyCompat dw EnumCompat TypeCompat endp AnyCompat proc near xor ax,ax ret AnyCompat endp StrictCompat proc near mov ax,[di].exType.Offs cmp ax,[si].exType.Offs jne @@1 mov ax,[di].exType.Segm cmp ax,[si].exType.Segm @@1: ret StrictCompat endp ProcCompat proc near push si di ds les di,[di].exType lds si,[si].exType cmpsw jne @@2 cmpsw jne @@2 cmpsw call ParamCompat jnz @@2 lodsw scasw jne @@2 xchg ax,cx jcxz @@2 @@1: call ParamCompat jnz @@2 cmpsb jne @@2 loop @@1 @@2: pop ds di si ret ProcCompat endp ParamCompat proc near cmpsw jne @@1 lodsw mov bx,es:[di] inc di inc di or ax,ax jz @@1 mov bx,es:[bx] xchg ax,bx cmp ax,[bx] @@1: ret ParamCompat endp SetCompat proc near les bx,[di].exType cmp es:[bx].stBase.Offs,0 je @@2 mov cx,es:[bx].stBase.Offs mov bx,es:[bx].stBase.Segm mov es,es:[bx] mov bx,cx mov ax,es:[bx].itBase.Offs mov bx,es:[bx].itBase.Segm mov dx,es:[bx] les bx,[si].exType cmp es:[bx].stBase.Offs,0 je @@1 mov cx,es:[bx].stBase.Offs mov bx,es:[bx].stBase.Segm mov es,es:[bx] mov bx,cx cmp ax,es:[bx].itBase.Offs jne @@1 mov bx,es:[bx].itBase.Segm cmp dx,es:[bx] @@1: ret @@2: mov ax,[si].exType.Offs mov [di].exType.Offs,ax mov ax,[si].exType.Segm mov [di].exType.Segm,ax ret SetCompat endp PointerCompat proc near call StrictCompat jz @@1 les bx,[si].exType mov ax,es:[bx].ptBase.Offs mov bx,es:[bx].ptBase.Segm mov es,es:[bx] mov bx,ax cmp es:[bx].tdSizeOf,0 je @@1 mov dx,es les bx,[di].exType mov cx,es:[bx].ptBase.Offs mov bx,es:[bx].ptBase.Segm mov es,es:[bx] mov bx,cx cmp es:[bx].tdSizeOf,0 jne @@1 mov ax,[si].exType.Offs mov [di].exType.Offs,ax mov ax,[si].exType.Segm mov [di].exType.Segm,ax @@1: ret PointerCompat endp EnumCompat proc near les bx,[di].exType mov ax,es:[bx].itBase.Offs mov bx,es:[bx].itBase.Segm mov dx,es:[bx] les bx,[si].exType cmp ax,es:[bx].itBase.Offs jne @@1 mov bx,es:[bx].itBase.Segm cmp dx,es:[bx] @@1: ret EnumCompat endp CastOrdinal proc near les bx,[si].exType cmp es:[bx].tdType,ttInteger jae _Cast ret CastOrdinal endp CastByte proc near mov bx,_Byte mov es,SystemUnit jmp short _Cast CastByte endp CastInt proc near mov bx,_Integer mov es,SystemUnit jmp short _Cast CastInt endp CastWord proc near mov bx,_Word mov es,SystemUnit jmp short _Cast CastWord endp CastLong proc near mov bx,_Longint mov es,SystemUnit _Cast label near cmp [di].exLocation,elImmediate jne @@2 mov ax,[di].itUpperBound.W0 mov dx,[di].itUpperBound.W2 call ImmedRangeCheck jc @@1 mov al,es:[bx].tdModifier or al,IndexModifier mov [di].exModifier,al ret @@1: mov ax,76 Chain CompileError @@2: test CompilerOptions,coRangeChk jnz @@4 @@3: mov al,es:[bx].tdModifier or al,IndexModifier Chain ConvertOrdinal @@4: xor ax,ax mov dx,ax test [di].exModifier,emSigned jz @@5 mov ax,-128 dec dx test [di].exModifier,emX jz @@5 mov ax,-32768 test [di].exModifier,emXX jz @@5 xchg ax,dx inc ax @@5: call ImmedRangeCheck jc @@8 mov ax,127 xor dx,dx test [di].exModifier,emUnsigned jz @@6 mov al,255 @@6: test [di].exModifier,emX jz @@7 mov ah,al mov al,255 test [di].exModifier,emXX jz @@7 mov dx,ax mov ax,65535 @@7: call ImmedRangeCheck jnc @@3 @@8: push es bx push es:[bx].itUpperBound push es:[bx].itLowerBound mov bx,sp mov ax,8 Invoke PutCodeConst push ax bx dx mov al,emLongint Invoke ConvertOrdinal Invoke UseExpr mov al,lvAX Invoke LoadValue mov al,0bfh ; mov ax, Invoke PutByte pop dx bx ax mov cx,ffCode+ffOffs Invoke PutFixup mov ax,_RangeCheck Invoke PutSystemCall Invoke DoneExpr add sp,8 pop bx es jmp @@3 CastLong endp ImmedRangeCheck proc near cmp dx,es:[bx].itLowerBound.W2 jg @@1 jl @@3 cmp ax,es:[bx].itLowerBound.W0 jb @@3 @@1: cmp dx,es:[bx].itUpperBound.W2 jl @@2 jg @@3 cmp ax,es:[bx].itUpperBound.W0 ja @@3 @@2: clc ret @@3: stc ret ImmedRangeCheck endp end