Programming samples by Robert Elton Maas <rem@BTR.Com>
Forth


These are excerpts from the file ForthScratch (17k bytes total):

( Simple constants, push the number on the stack )
HEX : SPCHR ( -- AsciiCodeForSpace ) 20 ; MACRO
HEX : 'CH ( -- AsciiCodeForApostrophe ) 27 ; MACRO
HEX : 2T8 ( -- 2**8 ) 100 ; MACRO

( Use these instructions to load registers A0 and D0 before register traps )
: >D0L ,$ 201E ( StackLong -> D0 ) ; MACRO
: >A0L ,$ 205E ( ??  Stack.long -> A0 ) ; MACRO

( Use these instructions to get registers A0 and D0 after register traps )
: <A0L ,$ 2D08 ( A0.long -> stack ) ; MACRO
: <D0  ,$ 3D00 ( D0.word -> stack ) ; MACRO
: <D0L ,$ 2D00 ( D0.long -> stack ) ; MACRO

( Memory-manager traps )
: FreeMem ( -- Nbytes.L )
    ,$ A01C ( _FreeMem )  <D0L ;
: NewHandle ( Size.long&SYS&CLEAR -- Handle.L ErrCode )
    >D0L  ,$ A122 ( _NewHandle )  <A0L <D0 ; ( unlocked & unpurgeable )
: GetHandleSize ( Handle.L -- result.L )
    >A0L  ,$ A025 ( _GetHandleSize )  <D0L ;
: HLock ( Handle.L -- ErrCode )
    >A0L  ,$ A029  <D0 ;
: HUnlock ( Handle.L -- ErrCode )
    >A0L  ,$ A02A  <D0 ;
: EmptyHandle ( Handle.L -- ErrCode )
    >A0L  ,$ A02B ( _EmptyHandle )  <D0 ;
: DisposHandle ( Handle.L -- ErrCode )
    >A0L  ,$ A023 ( _DisposHandle )  <D0 ;
: MaxBlock ( -- res.L )
   ,$ A061 ( _MaxBlock )  <D0L ;
: MoreMasters ( -- ErrCode )
   ,$ A036 ( _MoreMasters )  <D0 ;
: GetZone ( -- ptr.long ErrCode )
   ,$ A11A ( _GetZone )  <A0L <D0 ;
: HandleZone ( Handle.L -- ptr.L ErrCode )
   >A0L  ,$ A126 ( _HandleZone )  <A0L <D0 ;

( Standard-File dialog traps )
: PK3 ( stack usage depends on individual routine )
    ,$ A9EA ( _PACK3 ) ; MACRO
DECIMAL : B74Alloc ( -- Handle.L )
    74 0 NewHandle
    DUP IF ." Can't get NewHandle in B74Alloc, ERR=" . ABORT
           THEN DROP ;
: SFGetFile ( HReply.L -- )
    >A0L ( stash away HReply.L )
    100 100 2>R ( WherePoint = 100,100 = origin of dialog box )
    0 0 2>R ( PromptStringP.L = NIL not used )
    0 0 2>R ( FileFilterP.L = NIL not used )
    -1 >R ( numTypes = -1 = Ignore typeList and thus show all files )
    0 0 2>R ( and pass NIL in typeList )
    0 0 2>R ( ... pass NIL for dlgHook )
    <A0L 2DUP HLock IF ABORT THEN ( Fetch handle, lock it )
    DL@ 2>R ( just pass pointer )
    ( Trap itself: WherePoint.L=100,100 PromptStrP.L=NIL FileFilterP.L=NIL )
                 ( numTypes=-1 typeListP.L=NIL dlgHook.L=NIL PReply.L -- )
    2 >R PK3 ( _PACK3 #2 ) ;
( On return, at offset 0 byte is 0=cancel&ignore or 1=good, )
(  at offset 2 doubleword is OSType, )
(  at offset 6 word is VolRef, at offset 10 byte is length of filename, )
(  at offset 11 is start of filename. )
( I get back VolRef=8053 even though SFSaveDisk is 0001 )
(  and CurDirStore is 00010FA3 )
: SFPutFile ( HReply.L -- )
    >A0L ( stash away HReply.L )
    100 100 2>R ( WherePoint = 100,100 = origin of dialog box )
    0 0 2>R ( PromptStringP.L = NIL not used )
    0 0 2>R ( POrigName.L = NIL for empty initial string )
    0 0 2>R ( ... pass NIL for dlgHook )
    <A0L 2DUP HLock IF ABORT THEN ( Fetch handle, lock it )
    DL@ 2>R ( just pass pointer )
    ( Trap itself: WherePoint.L=100,100 PPromptStr.L=NIL POrigName.L=NIL )
                 ( dlgHook.L=NIL PReply.L -- )
    1 >R PK3 ( _PACK3 #1 ) ;
( On return, at offset 0 byte is 0=cancel&ignore or 1=good, )
(  at offset 2 doubleword is OSType, )
(  at offset 6 word is VolRef, at offset 10 byte is length of filename, )
(  at offset 11 is start of filename. )
: N@EMIT ( AbsAdr.L Nchars -- ) ( Emit characters starting at absolute adr )
    BEGIN DUP 0> WHILE ( SPCONT ) ROT ROT 2DUP BY@ EMIT
                       1 0 D+ ROT -1 + REPEAT ;
: OSEMIT ( AbsAddr.L -- ) ( Emit four chars at that address )
    2DUP BY@ EMIT 1 0 D+ 2DUP BY@ EMIT 1 0 D+ 2DUP BY@ EMIT 1 0 D+ BY@ EMIT ;
( HEX C59C 2 OSEMIT )
: HR. ( HReply.L OSflg -- ) ( Print out relevant info from HReply )
    ROT ROT DL@ 2DUP BY@ ( Valid.Boolean ) IF ELSE ." <Cancel>" ABORT THEN
    ROT IF ." OSTYPE =" 'CH EMIT 2DUP 2 0 D+ OSEMIT 'CH EMIT SPACE SPACE THEN
    ." VRef =" 2DUP 6 0 D+ L@ HEX U. SPACE
    ." LengthOfFilename =" 8 2 + 0 D+ 2DUP BY@ DECIMAL DUP .
    ROT ROT 1 0 D+ ROT CR ." FileName =" 'CH EMIT N@EMIT 'CH EMIT ;

( Given a single bit, print * or space accordingly )
HEX : PB IF 2A EMIT ELSE SPACE THEN ; DECIMAL

( Given a byte, print * or space for each bit )
HEX : PBY 8 BEGIN DUP WHILE
             SWAP 2 * 100 /MOD PB SWAP 1 - REPEAT
           DROP DROP ; DECIMAL

( Print out desktop pattern as 8 rows of 8 bits each )
HEX : PDP A3C 8 BEGIN DUP WHILE
          SWAP DUP 0 BY@ PBY CR 1 + SWAP 1 - REPEAT
        DROP DROP ; DECIMAL