; ; File: ObjMacros.a ; ; Contains: xxx put contents here xxx ; ; Written by: xxx put writers here xxx ; ; Copyright: © 1991 by Apple Computer, Inc., all rights reserved. ; ; Change History (most recent first): ; ; <7> 1/30/91 gbm sab, #38: Change the ‘already including this file’ 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