Macintosh-SW/mac-rom
1
0
Fork 0
mirror of https://github.com/elliotnunn/mac-rom.git synced 2025-01-07 20:29:52 +00:00
Code Issues Projects Releases Wiki Activity
6d103981d8
mac-rom/Interfaces/AIncludes/ObjMacros.a

508 lines
13 KiB
Plaintext
Raw Normal View History

Bring in CubeE sources Resource forks are included only for .rsrc files. These are DeRezzed into their data fork. 'ckid' resources, from the Projector VCS, are not included. The Tools directory, containing mostly junk, is also excluded.
2017-09-17 09:09:04 +00:00
;
; File: ObjMacros.a
;
; Contains: xxx put contents here xxx
;
; Written by: xxx put writers here xxx
;
; Copyright: <09> 1991 by Apple Computer, Inc., all rights reserved.
;
; Change History (most recent first):
;
; <7> 1/30/91 gbm sab, #38: Change the <20>already including this file<6C> variable to
; all uppercase (for security reasons)
;
; To Do:
;
; Version: 3.04
; Created: Friday, October 20, 1989 at 9:32:41 PM
;
; File: ObjMacros.a
;
; Assembler Interface to the Macintosh Libraries
; Copyright Apple Computer, Inc. 1986-1988
; All Rights Reserved.
;
;--------------------------------------------------------------------
; This file contains:
; Macros to support Object Assembler
; The InitObjects macro
; A template for TObject, the suggested root class for all objects
;
; The usable Macros in this file are documented in both the Assembler
; and MacApp manuals. Those macros are:
;
; ObjectDef
; ObjectIntf
; ObjectWith
; EndObjectWith
; ProcMethOf
; FuncMethOf
; EndMethod
; MethCall
; Inherited
; MoveSelf
; NewObject
; InitObjects
;
;
; Current limitations:
; 250 classes
; unlimited methods
;
; Object assembler programmers who do not use a Pascal main program
; MUST call the InitObjects macro at the beginning of their program.
;--------------------------------------------------------------------
;
; Modification history:
; *** MPW 2.0 ***
;--------------------------------------------------------------------
IF &TYPE('__INCLUDINGOBJMACROS__') = 'UNDEFINED' THEN
__INCLUDINGOBJMACROS__ SET 1
IMPORT %_METHOD
IMPORT %_OBNEW
IF &TYPE('ObjOptFlag') = 'UNDEFINED' THEN
ObjOptFlag: EQU 0
ENDIF
IF &TYPE('DebugFlag') = 'UNDEFINED' THEN
DebugFlag: EQU 1
ENDIF
MACRO
REFSELECTOR &ProcName,&ItsObjIndex,&OpCode
GBLA &ObjSupers[250],&MethLists[250], &MethTable
GBLC &ObjNames[250]
LCLA &start,&found,&objIndex,&LexInt
&found: SETA 0
IF &FINDSYM(&MethTable,&ProcName) THEN
&start: SETA 1
GOTO .EndLoop
WHILE &SYSTOKEN <> 30 DO
&LexInt: SETA &S2I(&SYSTOKSTR)
&objIndex: SETA &ItsObjIndex
WHILE (&objIndex <> 0) DO
IF &LexInt = &objIndex THEN
&OpCode &ObjNames[&objIndex]$&ProcName
&objIndex: SETA 0
&found: SETA 1
ELSE
&objIndex: SETA &ObjSupers[&objIndex]
ENDIF
ENDWHILE
.EndLoop
&start: SETA &LEX(&SYSVALUE, &start)
WHILE (&SYSTOKEN <> 1) AND (&SYSTOKEN <> 30) DO
&start: SETA &LEX(&SYSVALUE, &start)
ENDWHILE
ENDWHILE
ENDIF
IF &found = 0 THEN
AERROR &Concat('Error trying to reference method: ',&ProcName)
ENDIF
ENDMACRO
MACRO
SELECTORPROC &ProcName
LCLC &SaveSeg
&SaveSeg: SETC &SYSSEG
SEG '%_SelProcs'
&ProcName: PROC EXPORT
JSR %_METHOD
ENDPROC
SEG '&SaveSeg'
ENDMACRO
MACRO
ObjectTemplate &TypeName,&Heritage=NIL,&IntfOnly:INT=0
GBLA &ObjSupers[250],&MethLists[250]
GBLC &ObjNames[250]
GBLA &lastObjIndex, &currMethIndex, &MethTable
GBLA &NumFields,&NumMethods
GBLC &FieldList[250],&MethodList[250]
LCLA &methNum, &fieldNum, &objIndex
LCLC &SaveSeg, &RootIndex
LCLA &SuperIndex, &NumChars, &Temp
LCLA &methIndex, &foundIndex, &MethFlag, &SymReturn
LCLC &TempArray[1],&CurrField[2],&CurrMethod[3]
IF &MethTable = 0 THEN
&MethTable: SETA &NEWSYMTBL
ENDIF
&lastObjIndex: SETA &lastObjIndex+1
&ObjNames[&lastObjIndex]: SETC &TypeName
&MethLists[&lastObjIndex]: SETA &currMethIndex+1
IF (&Heritage = 'NIL') THEN
&ObjSupers[&lastObjIndex]: SETA 0
ELSE
&SuperIndex: SETA 1
&ObjNames[&lastObjIndex+1]: SETC &Heritage
WHILE (&ObjNames[&SuperIndex] <> &Heritage) DO
&SuperIndex: SETA &SuperIndex+1
ENDWHILE
IF (&SuperIndex > &lastObjIndex) THEN
AERROR &Concat('Non-existent Ancestor Object Type: ',&Heritage)
ELSE
&ObjSupers[&lastObjIndex]: SETA &SuperIndex
ENDIF
ENDIF
IF &NumFields >= 0 THEN
&fieldNum: SETA 1
%&TypeName: RECORD &Heritage.Offset
WHILE &fieldNum <= &NumFields DO
&NumChars: SETA &LEN(&FieldList[&fieldNum])-2
&Temp: SETA &LIST(&FieldList[&fieldNum,2:&NumChars], '&CurrField')
IF &Eval(&CurrField[2]) >= 2 THEN
ALIGN 2
ENDIF
&CurrField[1]: DS.B &CurrField[2]
&fieldNum: SETA &fieldNum+1
ENDWHILE
ALIGN 2
last: EQU *
ENDR
&TypeName.Offset: EQU %&TypeName..last
ENDIF
IF &NumMethods > 0 THEN
&methNum: SETA 1
WHILE &methNum <= &NumMethods DO
&NumChars: SETA &LEN(&MethodList[&methNum])-2
&CurrMethod[2]: SETC ''
&CurrMethod[3]: SETC ''
&Temp: SETA &LIST(&MethodList[&methNum,2:&NumChars], '&CurrMethod')
IF (&CurrMethod[2] = '') OR (&UC(&CurrMethod[2]) = 'IMPL') THEN
IF (&UC(&CurrMethod[2]) = 'IMPL') THEN
IF &IntfOnly THEN
IMPORT &TypeName.$&CurrMethod[1]
ELSE
AERROR &Concat('IMPL only allowed in ObjectIntf Macro. Error at ', \
&CurrMethod[1],' in ',&TypeName)
ENDIF
ELSEIF &IntfOnly THEN
IMPORT &TypeName.$&CurrMethod[1]
ELSE
SELECTORPROC &TypeName.$&CurrMethod[1]
ENDIF
&currMethIndex: SETA &currMethIndex+1
&SymReturn: SETA &ENTERSYM(&MethTable,&I2S(&currMethIndex),&CurrMethod[1],0)
* First do findsym to see if other unrelated root classes
IF &FINDSYM(&MethTable,&CurrMethod[1]) THEN
&RootIndex: SETC &Concat(&SYSVALUE,' ',&I2S(&lastObjIndex))
&MethFlag: SETA &SYSFLAGS+1
ELSE
&RootIndex: SETC &I2S(&lastObjIndex)
&MethFlag: SETA 1
ENDIF
&SymReturn: SETA &ENTERSYM(&MethTable,&CurrMethod[1],&RootIndex,&MethFlag)
ELSEIF (&UC(&CurrMethod[2]) <> 'OVERRIDE') THEN
AERROR &Concat(&CurrMethod[2],' illegal after ',&CurrMethod[1], \
' in ',&TypeName)
ENDIF
IF NOT &IntfOnly THEN
EXPORT &TypeName._&CurrMethod[1]
ELSEIF (&UC(&CurrMethod[2]) = 'IMPL') OR (&UC(&CurrMethod[3]) = 'IMPL') THEN
EXPORT &TypeName._&CurrMethod[1]
ELSE
IMPORT &TypeName._&CurrMethod[1]
ENDIF
&methNum: SETA &methNum+1
ENDWHILE
IF NOT &IntfOnly THEN
&SaveSeg: SETC &SYSSEG
SEG '%_MethTables'
CODEREFS FORCEJT
_&TypeName: PROC EXPORT
DC.W _&TypeName
IF &Heritage = 'NIL' THEN
DC.W 0
ELSE
DC.W _&Heritage
ENDIF
DC.W &TypeName.Offset
DC.W &methNum-1
&methNum: SETA 1
WHILE &methNum <= &NumMethods DO
&NumChars: SETA &LEN(&MethodList[&methNum])-2
&CurrMethod[2]: SETC ''
&CurrMethod[3]: SETC ''
&Temp: SETA &LIST(&MethodList[&methNum,2:&NumChars], '&CurrMethod')
IF (&CurrMethod[2] = '') THEN
DC.W &TypeName.$&CurrMethod[1]
ELSEIF (&UC(&CurrMethod[2]) = 'OVERRIDE') THEN
IF &superIndex = 0 THEN
AERROR &Concat('Override of Non-existent method: ',&CurrMethod[1])
ELSE
REFSELECTOR &CurrMethod[1],&superIndex,DC.W
ENDIF
ENDIF
IMPORT &TypeName._&CurrMethod[1]
DC.W &TypeName._&CurrMethod[1]
&methNum: SETA &methNum+1
ENDWHILE
ENDPROC
SEG '&SaveSeg'
CODEREFS NOFORCEJT
ELSE
IMPORT _&TypeName
ENDIF
ENDIF
&MethLists[&lastObjIndex+1]: SETA &currMethIndex+1
ENDMACRO
MACRO
ObjectDef &TypeName,&Heritage=NIL
GBLA &NumFields,&NumMethods
GBLC &FieldList[250],&MethodList[250]
LCLA &index1, &index2
&index1: SETA 3
&index2: SETA 1
WHILE &NBR(&SYSLIST[&index1]) <> 0 DO
&FieldList[&index2]: SETC &SYSLIST[&index1]
&index1: SETA &index1+1
&index2: SETA &index2+1
ENDWHILE
&NumFields: SETA &index2-1
&index2: SETA 1
IF &SYSLIST[&index1] = 'METHODS' THEN
&index1: SETA &index1+1
WHILE &NBR(&SYSLIST[&index1]) <> 0 DO
&MethodList[&index2]: SETC &SYSLIST[&index1]
&index1: SETA &index1+1
&index2: SETA &index2+1
ENDWHILE
ENDIF
&NumMethods: SETA &index2-1
ObjectTemplate &TypeName,&Heritage,0
ENDMACRO
MACRO
ObjectIntf &TypeName,&Heritage=NIL
GBLA &NumFields,&NumMethods
GBLC &FieldList[250],&MethodList[250]
LCLA &index1, &index2
&index1: SETA 3
&index2: SETA 1
WHILE &NBR(&SYSLIST[&index1]) <> 0 DO
&FieldList[&index2]: SETC &SYSLIST[&index1]
&index1: SETA &index1+1
&index2: SETA &index2+1
ENDWHILE
&NumFields: SETA &index2-1
&index2: SETA 1
IF &SYSLIST[&index1] = 'METHODS' THEN
&index1: SETA &index1+1
WHILE &NBR(&SYSLIST[&index1]) <> 0 DO
&MethodList[&index2]: SETC &SYSLIST[&index1]
&index1: SETA &index1+1
&index2: SETA &index2+1
ENDWHILE
ENDIF
&NumMethods: SETA &index2-1
ObjectTemplate &TypeName,&Heritage,1
ENDMACRO
MACRO
OBJECTWITH &TypeName
GBLA &WithLevel[8]
GBLA &WithIndex
GBLA &ObjSupers[*]
GBLC &ObjNames[*]
GBLA &lastObjIndex
GBLC &currObjName,&currSuperName
GBLA &currObjIndex
LCLA &SuperIndex
&currObjName: SETC &TypeName
&SuperIndex: SETA 1
&ObjNames[&lastObjIndex+1]: SETC &TypeName
WHILE &ObjNames[&SuperIndex] <> &TypeName DO
&SuperIndex: SETA &SuperIndex+1
ENDWHILE
&currObjIndex: SETA &SuperIndex
IF &SuperIndex > &lastObjIndex THEN
AERROR &Concat('Object Type name does not exist: ',&TypeName)
ELSE
IF &ObjSupers[&SuperIndex] = 0 THEN
&currSuperName: SETC 'NIL'
ELSE
&currSuperName: SETC &ObjNames[&ObjSupers[&SuperIndex]]
ENDIF
WITH %&TypeName
&WithIndex: SETA &WithIndex+1
WHILE &ObjSupers[&SuperIndex] <> 0 DO
WITH %&ObjNames[&ObjSupers[&SuperIndex]]
&WithLevel[&WithIndex]: SETA &WithLevel[&WithIndex]+1
&SuperIndex: SETA &ObjSupers[&SuperIndex]
ENDWHILE
ENDIF
ENDMACRO
MACRO
METHOD &MethName,&TypeName,&FuncORProc=PROC
&TypeName._&MethName: &FuncORProc EXPORT
OBJECTWITH &TypeName
ENDMACRO
MACRO
&MethName: ProcMethOf &TypeName
METHOD &MethName,&TypeName,PROC
ENDMACRO
MACRO
&MethName: FuncMethOf &TypeName
METHOD &MethName,&TypeName,FUNC
ENDMACRO
MACRO
ObjectEndWith
ENDWITH
GBLA &WithLevel[*]
GBLA &WithIndex
IF &WithIndex > 0 THEN
WHILE &WithLevel[&WithIndex] > 0 DO
ENDWITH
&WithLevel[&WithIndex]: SETA &WithLevel[&WithIndex]-1
ENDWHILE
&WithIndex: SETA &WithIndex-1
ENDIF
ENDMACRO
MACRO
ENDMETHOD
ObjectEndWith
ENDPROC
ENDMACRO
MACRO
METHCALL &MethName,&ObjTypeName
GBLC &ObjNames[*]
GBLA &currObjIndex, &lastObjIndex
LCLA &objIndex
IF &ObjTypeName = '' THEN
&objIndex: SETA &currObjIndex
ELSE
&objIndex: SETA 1
&ObjNames[&lastObjIndex+1]: SETC &ObjTypeName
WHILE &ObjNames[&objIndex] <> &ObjTypeName DO
&objIndex: SETA &objIndex+1
ENDWHILE
ENDIF
IF &objIndex > &lastObjIndex THEN
AERROR &Concat('Unknown Object type Name: ',&ObjTypeName)
ELSEIF ObjOptFlag THEN
JSR &ObjNames[&objIndex]$&MethName
ELSE
REFSELECTOR &MethName,&objIndex,JSR
ENDIF
ENDMACRO
MACRO
INHERITED &MethName
GBLC &ObjNames[*]
GBLA &ObjSupers[*]
GBLA &currObjIndex
LCLA &objIndex
&objIndex: SETA &ObjSupers[&currObjIndex]
WHILE (&TYPE(&Concat(&ObjNames[&objIndex],'_',&MethName)) = 'UNDEFINED') AND (&objIndex <> 0) DO
&objIndex: SETA &ObjSupers[&objIndex]
ENDWHILE
IF &objIndex = 0 THEN
AERROR &Concat('Inherited error; Method not defined in ancestor: ',&MethName)
ELSE
IMPORT &ObjNames[&objIndex]_&MethName
JSR &ObjNames[&objIndex]_&MethName
ENDIF
ENDMACRO
MACRO
MoveSelf &Dest
MOVE.L 8(A6),&Dest
ENDMACRO
MACRO
NewObject &Loc,&TypeName,&Size
PEA &Loc
PEA _&TypeName+2
IF &Size = '' THEN
MOVE.W #&TypeName.Offset,-(SP)
ELSE
MOVE.W #&Size,-(SP)
ENDIF
JSR %_OBNEW
ENDMACRO
* The InitObjects macro must be called if the main program is not in Pascal
IMPORT %_PGM1
MACRO
InitObjects
JSR %_PGM1
ENDMACRO
NILOffset EQU 2
IF DebugFlag THEN
ObjectIntf TObject,, \ Suggested root class for all objects
METHODS, \ no data fields
(ShallowClone), \ Object copying method; rarely overridden
(Clone), \ Can be overriden to clone fields
(ShallowFree), \ Frees object; rarely overridden
(Free), \ Can be overriden to free fields
(ClassName), \ Returns name of class
(Inspect) ; Print info to debug window
ELSE
ObjectIntf TObject,, \ Suggested root class for all objects
METHODS, \ no data fields
(ShallowClone), \ Object copying method; rarely overridden
(Clone), \ Can be overriden to clone fields
(ShallowFree), \ Frees object; rarely overridden
(Free) ; Can be overriden to free fields
ENDIF
ENDIF ; ...already included
Reference in New Issue Copy Permalink