Celestin Apprentice 4

home *** CD-ROM | disk | FTP | other *** search

/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Module source / tool.txt < prev next >

Wrap

Text File | 1995-10-13 | 8.1 KB | 389 lines | [TEXT/MSET]

\ Construct table of names & traps for toolbox calls false value DOING_GLOBALS? 9 constant TAB :class CSARRAY super{ object } 16 indexed :m AT: \ ( index -- addr len ) ^elem count ;m :m TO: \ ( addr len index -- ) ^elem place ;m ;class :class WARRAY super{ object } 2 indexed :m AT: \ ( index -- n ) inline{ ix w@} ^elem w@ ;m :m TO: \ ( n index -- ) inline{ ix w!} ^elem w! ;m :m +TO: \ ( n index -- ) inline{ ix w+!} ^elem w+! ;m :m -TO: \ ( n index -- ) inline{ ix w-!} ^elem w-! ;m :m ^ELEM: \ ( index -- addr ) inline{ ix} ^elem4 ;m :m FILL: \ ( value -- ) Fills all elements with value. idxbase limit 2* bounds ?DO dup i w! 2 +LOOP drop ;m ;class :class COUNTED_STRINGS super{ object } 1 indexed record { int SIZE } :m GETSIZE: get: size ;m :m ADD: { addr len -- } addr len get: size ^elem1 place get: size len + 1+ put: size ;m :m AT: \ ( idx -- addr len ) ^elem1 count ;m ;class :class HASHTABLE super{ array } record { int MASK } private :m LOOKUP: { val \ ixb strt end addr -- index b } idxbase -> ixb val get: mask and ixb + dup -> strt -> addr ixb get: mask + 1+ -> end BEGIN addr @ NIF addr idxbase - 4/ false EXIT THEN addr @ val = IF ( found ) addr ixb - 4/ true EXIT THEN 4 ++> addr addr end >= IF ixb -> addr ELSE addr strt = IF 50 die THEN THEN AGAIN ;m public :m INDEXOF: \ ( val -- index T | -- F ) lookup: self IF true EXIT THEN drop false ;m :m ENTER: { val \ idx found? -- idx b } val lookup: self -> found? -> idx found? iF idx false EXIT THEN val idx to: super idx true ;m :m CLASSINIT: limit 1- 2 << put: mask ;m ;class :class STRINGARRAY super{ string array } record { int CURRENT } :m CURRENT: get: current ;m :m (SEL): { idx -- } idx put: current idx at: self ^base ! nil?: self ?EXIT ^base size: handle put: size ;m :m SELECT: { idx -- } idx (sel): self nil?: self IF \ new: not done - do it now new: super handle: self idx to: self ELSE reset: self THEN ;m :m RELEASE: limit 0 DO i (sel): self release: super \ Harmless if not open nilH i to: self LOOP ;m :m CLEARALL: limit 0 DO i (sel): self handle: self IF clear: super THEN LOOP ;m :m DUMP: ." Current:" get: current . cr dump: super ;m :m CLASSINIT: idxbase limit 4* bounds DO nilH i ! 4 +LOOP ;m ;class string TEMP 2048 hashtable TRAPNAMES 2048 Warray TRAP_INDEXES 10000 counted_strings TRAPS 2048 stringarray $TNAMES 512 hashtable GNAMES 512 array GLOBALS 4096 hashtable KNAMES \ 4096 array KONSTANTS 0 value #DBL 0 value #TRAPS 0 value #GLOBALS 0 value #KONSTANTS : CHAROF { addr chr -- offs T | -- F } \ Addr is of a str255 string. Offs refers to found char. addr count chr scan IF addr - 1- true ELSE drop false THEN ; : READ_INLINE { \ loc -- } clear: temp BEGIN >in @ src-len >= ?EXIT hex intrp1 pad w! pad 2 add: temp AGAIN ; true value DBLFAIL? : TRAPNAME { \ hashval s255 idx dbl? -- } source bl scan ( addr len ) IF 1+ src-start - >in ! ELSE drop THEN Mword -> s255 \ Trap name s255 hash -> hashval hashval enter: trapnames not -> dbl? -> idx dbl? IF idx select: $tnames get: $tnames s255 count s= NIF here count cr type ." - hash collision!!" cr abort THEN 1 ++> #dbl EXIT THEN idx select: $tnames s255 count put: $tnames read_inline getSize: traps idx to: trap_indexes all: temp add: traps 1 ++> #traps ; : GLOBNAME { \ hashval val s255 -- } \ Gets next word, adds if tool name, records parm if applicable Mword hex number -> val \ global value Mword -> s255 \ name s255 hash -> hashval hashval enter: gnames NIF ( match - check for hash collision ) at: globals val <> IF ( hash collision - FAIL ) here count cr type ." - hash collision!!" cr abort THEN 1 ++> #dbl EXIT THEN val swap to: globals 1 ++> #globals ; : HANDLE_LINE \ ( glob? -- ) IF globname ELSE trapname THEN ; : TOOLS" { glob? \ radix svecho -- } \ Reads toolbox name/trap table and fills arrays. base -> radix echo? -> svecho new: temp pushNew: loadFile setName: topfile openReadOnly: topfile ?error 149 false -> endload? BEGIN ( read until eof ) (Frefill) WHILE tib c@ & \ <> \ skip comments if glob? handle_line then REPEAT drop: loadFile release: temp radix -> base svecho -> echo? ; \ The "konstants" file can be interpreted as a source file, since \ it consists of lines of the form \ \ 1234 konstant Name \ \ The following word KONSTANT does the hard work. (* : KONSTANT \ ( value --<name> ) dup constant \ Define the name as a constant so \ later konsts can refer to it latest hash \ Get the name, hash it enter: knames NIF ( match - check for hash collision ) at: konstants <> IF ( hash collision - FAIL ) here count cr type ." - hash collision!!" cr abort THEN 1 ++> #dbl EXIT THEN to: konstants 1 ++> #konstants ; *) (* buggy: : 'TYPEX \ ( --< 'xxxx' > ) Modified 'TYPE to use with KONSTANT pad 4 bl fill & ' scan-src source drop & ' scan-src source drop over - 4 min pad swap cmove pad @ postpone lit ; immediate *) : 'TYPEX \ ( --< 'xxxx' > ) Modified 'TYPE to use with KONSTANT pad 4 bl fill & ' word count 4 min pad swap cmove pad @ postpone lit ; immediate \ load the calls etc. 4 constant midiToolNum $ A830 constant _pack14 false -> dblFail? cr .( Loading trap names...) false tools" calls" cr #dbl . .( double-ups - ignore them) 0 -> #dbl cr #traps . .( trap names stored. ) cr getSize: traps . .( bytes used for traps storage) release: $tnames cr .( Loading low memory global names...) true tools" globals" cr #globals . .( global names stored) cr #dbl . .( double-ups in globals) 0 -> #dbl (* cr .( Loading konsts...) // konstants cr #konstants . .( konsts stored) cr #dbl . .( double-ups in konsts) 0 -> #dbl *) forget read_inline \ dump table generation code : @TRAP { tStr \ mStr flg addr len -- addr len } \ Gets inline call sequence for a trap name. tStr is str255. \ I don't think we need the following now - "PBxxx" calls are still in my current \ header files. If they ever disappear, we can reinstate this code: \ tStr count 2 min " PB" s= \ IF ( PB file calls now have the PB omitted ) \ tStr count 2 /string str255 -> tStr \ THEN 0 -> mStr tStr & , charOf \ stop short of comma if any IF dup tStr c! tStr + 2+ -> mStr THEN tStr hash indexOf: trapnames not ?error 150 at: trap_indexes at: traps -> len -> addr \ That's the call sequence mStr IF \ a modifier exists true CASE mStr 4 " REGS" s= OF $ 01 ENDOF \ GetTrapAddr mStr 5 " ASYNC" s= OF $ 04 ENDOF \ device drivers mStr 5 " IMMED" s= OF $ 02 ENDOF \ control calls mStr 3 " SYS" s= OF $ 04 ENDOF \ Memory Manager mStr 5 " CLEAR" s= OF $ 02 ENDOF mStr 5 " MARKS" s= OF $ 04 ENDOF \ String Compares mStr 4 " CASE" s= OF $ 02 ENDOF 164 die \ Illegal modifier name ENDCASE addr c@ $ F0 and $ A0 <> ?error 151 \ call seq must start $Axxx addr pad len cmove pad -> addr addr c@ or addr c! THEN addr len ; : @GLOB \ ( str-addr -- glob# ) hash indexOf: gnames 0= ?error 150 at: globals ; \ : @KONST \ ( str-addr -- konst ) \ hash indexOf: knames 0= ?error 150 \ at: konstants ; : (,TRAP) \ ( addr len -- ) tuck here swap cmove align allot ; : ,TRAP \ ( addr len -- ) Compiles the given inline code sequence. SavA5 (,trap) RstA5 ; : ,FCALL \ Trap dispatcher for low-level File Manager $ 205E w, \ move.l (a6)+,a0 ; FCB pointer ,trap $ 48C0 w, \ ext.l d0 ; Result $ 2D00 w, ; \ move.l d0,-(a6) \ Now the exported words: : ASMCALL \ ( addr len -- ) Compiles the trap. str255 count upper buf255 @trap tuck here swap cmove align allot ; : CALL ?comp Mword @Trap ,trap ; immediate : FCALL ?comp Mword @Trap ,fcall ; immediate : GLOBAL Mword @glob postpone lit ; immediate : $>GLOB \ ( addr len -- glob ) str255 count upper buf255 @glob ; \ : KONST \ Mword @konst postpone lit ; immediate \ : $>KONST \ ( addr len -- konst ) \ str255 count upper buf255 @konst ;