Macintosh-SW/supermario
1
0
Fork 0
mirror of https://github.com/elliotnunn/supermario.git synced 2024-07-17 06:28:58 +00:00
Code Issues Projects Releases Wiki Activity
5122302da6
supermario/base/SuperMarioProj.1994-02-09/Interfaces/AIncludes/ObjMacros.a

508 lines
13 KiB
Plaintext
Raw Normal View History

Bring in sources, and document
2019-06-29 15:17:50 +00:00
;
; 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
Reference in New Issue Copy Permalink