diff --git a/Makefile b/Makefile index 089829fe..e65a977e 100644 --- a/Makefile +++ b/Makefile @@ -44,7 +44,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ mits_s rab stan_k bs cstacy kp dcp2 -pics- victor imlac rjl mb bh \ lars drnil radia gjd maint bolio cent shrdlu vis cbf digest prs jsf \ decus bsg muds54 hello rrs 2500 minsky danny survey librm3 librm4 \ - klotz atlogo clusys cprog r eb cpm mini nova sits + klotz atlogo clusys cprog r eb cpm mini nova sits nlogo DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ @@ -52,7 +52,7 @@ DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ aplogo _temp_ pdp11 chsncp cbf rug bawden llogo eak clib teach pcnet \ combat pdl minits mits_s chaos hal -pics- imlac maint cent ksc klh \ digest prs decus bsg madman hur lmdoc rrs danny netwrk klotz hello \ - clu r mini nova sits jay rjl + clu r mini nova sits jay rjl nlogo BIN = sys sys1 sys2 emacs _teco_ lisp liblsp alan inquir sail comlap \ c decsys graphs draw datdrw fonts fonts1 fonts2 games macsym \ maint _www_ gt40 llogo bawden sysbin -pics- lmman shrdlu imlac \ diff --git a/build/misc.tcl b/build/misc.tcl index b3c98999..91ed65a7 100644 --- a/build/misc.tcl +++ b/build/misc.tcl @@ -1654,6 +1654,11 @@ expect ":KILL" respond "*" ":palx inquir\r" expect ":KILL" +# SLOGO, 11LOGO for SITS. +respond "*" ":cwd nlogo\r" +respond "*" ":palx slogo_@slogo\r" +expect ":KILL" + # TORTIS respond "*" ":midas;324 radia;_tortis\r" expect ":KILL" diff --git a/build/timestamps.txt b/build/timestamps.txt index 61e883ad..81ac766f 100644 --- a/build/timestamps.txt +++ b/build/timestamps.txt @@ -1600,6 +1600,21 @@ nilcom/subseq.39 198110271102.42 nilcom/thread.8 198109291240.03 nilcom/vsaid.57 198002230700.52 nilcom/yesnop.44 198109011735.21 +nlogo/-read-.-this- 197706222011.32 +nlogo/common.23 197911252329.07 +nlogo/contro.81 197911252329.21 +nlogo/displa.31 197910012008.57 +nlogo/eval.119 197902020417.26 +nlogo/filing.110 197911252329.13 +nlogo/gtfun.89 197910181535.11 +nlogo/iggl.1 197711221847.09 +nlogo/impure.77 197911252329.15 +nlogo/init.56 197911252329.05 +nlogo/logoch.497 197808071946.48 +nlogo/pure.96 197911252329.09 +nlogo/sitss.3 197911252126.36 +nlogo/slogo.cmd 197711231620.13 +nlogo/storag.15 197905170325.36 nova/-read-.-this- 197609090702.48 nova/_lodee.0_11 197103061932.19 nova/debug.1 197312212120.12 diff --git a/doc/nlogo/-read-.-this- b/doc/nlogo/-read-.-this- new file mode 100755 index 00000000..815f5fb6 --- /dev/null +++ b/doc/nlogo/-read-.-this- @@ -0,0 +1,2 @@ +This currently contains the sources for LOGO. +Other versions of LOGO are contained on the 11LOGO; directory \ No newline at end of file diff --git a/doc/nlogo/logoch.497 b/doc/nlogo/logoch.497 new file mode 100755 index 00000000..8a19b5c5 --- /dev/null +++ b/doc/nlogo/logoch.497 @@ -0,0 +1,348 @@ +New things in LOGO versions greater than 350: + +The disk error system has been revamped. The new format of +error messages from disk functions is: +: +In the case of the general file-not-found type of error message: +: +Note that the file-not-found type of error message is generally +generated whenever the failing operation involved a file +name; the reson for failure might be something other than +file not found. The function name given is that of the LOGO +function that caused the error. On the floppy disk system, most +types of hardware disk errors now trap back properly to +the LOGO user. There are two types of hardware disk errors: the +type which simply causes an abort of the current function and +clobbers the channel, and the type that indicates that the diskette +file structure might have been clobbered and the disk should +be checked with SALV. The english text for the first is +"DISK ERROR" the second is "BAD DISK ERROR, CHECK DISK". +The french text for the new errors is not yet complete; some +of them just give the english text. The new error system is +not yet complete in another sense: while disk errors always +(I think) give a reasonable error message back to the user, +hardware disk errors can cause the file system to become +wedged in strange ways. I intend to debug this when I have a +machine to debug it on. + +More MFI (master file item) blocks have been allocated, to reduce +the chance that a file can't be opened due to a lack of them. +There is now a proper error message ("too many files open") +given if you do run out of these. + +READ can now be done while defining a procedure. If the procedure +being defined is also defined in the file, the file definition +will be SKIPPED in the usual way. When the file has finished +being read, the user will be still defining the procdure he +was defining when the READ was executed. + +POI (and PO TREE) are now much faster. Also, they now print on +the last line, in addition to the free blocks and disk number, +the number of blocks used by the directory just printed. Note +that at the moment directories count as taking no blocks, while +in fact they take one. + +The entire 2500 display system LOGO driver has been revamped. +LOGO now tries to keep track of snap space and display space, +as well as x and y coordinates. Thus, the commands XCOR, YCOR, +HEADING and HERE now work for the 2500 (sometimes). The (sometimes) +is due to the fact that, because of insufficient 2500/LOGO communication, +LOGO sometimes loses track of the turtle on the 2500. This +condition is known as the turtle being dizzy. The turtle becomes +dizzy due to MOVET or SPIN commands; also RUBDIS will make the turtle +dizzy. DISPLAY does NOT make the turtle dizzy, by virtue of the +fact that the displayed snap has no effect on the x, y, heading +or pen state. In order to implement this, the DISPLAY command +now represnets 6 2500 words if the pen is up and 7 if it is +down when the DISPLAY command is issued. Once the turtle is dizzy, +it remains dizzy until the next CLEARSCREEN command. Once the +turtle is dizzy LOGO no longer makes any attempt to figure +out where it is; this is equivelant to the old mode of +running the 2500, and is much faster than the new mode. The +turtle can be made permanently dizzy (to enter "old mode") +by doing DIZZY 1; DIZZY 0 will clear that state. Also note that +when the turtle is dizzy, DISPLAY is a 2 word command again, +just like old times. SNAP has also changed drastically; the old +effect of snap can be had with the command OSNAP. New SNAP does not +take an argument; rather, it returns a value. LOGO now keeps track +of the lenght of the current display list and snap area. When SNAP +is executed LOGO attemts to assign the new snap room under all of +the old snaps; if there is enough room it issues the proper SNAP +command to the 2500 and returns the address of the bottom of the area +it assigned. Note that old snaps never go away, unless the WIPECLEAN +command is issued (the name of this command may be changed). Internal +to LOGO 2500 snaps are just numbers; LOGO does not keep track which +snaps are contained in other snaps, or are displayed on the screen. + +There is a new command .LPCNT which takes 0 or 1 arguments. Given 0 +arguments it returns a number which is current line printer line +count; given 1 argument it sets the line count to the given value. +Thus a LOGO program can attmpt to maintain page boundaries by +checking .LPCNT often enough, and when it exceeds a set value, +space the printer over the perforations and set .LPCNT back to zero. + +The system trace functions (.STF and .CTF) and the explicit call +to the LSI-11 memory checker (.SYSCHK) have been removed. + +POF will now always work, if there is at least one free channel, +as will SETI and USE. POF will normally use channel zero, as before, +but if channel zero is in use POF will choose a free channel. +Note that if you are dribbling at the same time as POFing, +and POF can't get the buffered channel (channel zero), in the +LSI version two disk transfers will happen for every character +printed. POF now quits immediately on G rather than +just inhibiting printing until the file is all "printed". + +An important internal change: the number of arguments passed to +a variable number of arguments procedure is now passed in D rather than +on the top of the stack. Also, the standard number of args range +is now 0 to 7 rather than 0 to 3. + +The comment character has been changed from ! to ;. For the momment ! +will still be acepted, but LOGO will change it to ;. Presumably +at some later date the meaning of ! will go away completely. + +It is no longer nessesary to put : in front of the names of +argument variables on the title line; however, atempting to +use a variable name that cooresponds to a system abbreviation +in this way will expand the abreviation. Thus: + TO FOO :A :B :FIRST +is the same as + TO FOO A B F +because the F gets expanded to FIRST. Also, the magic word USING +(AVEC in french) or LOCAL will specify the following variables +as being local to the procedure: + TO FOO A B USING C D +FOO has two arguments and two local variables. + +String addition and subtraction are now supported. The maximum length +of the numbers is subject to change, but at the moment is 20 digits +(I think). SPLUS and SMINUS are the two defined operations on string numbers. + +The functions CATCH and THROW have been implemented. CATCH is similar to RUN, +if the procedure(s) executed by the CATCH do a THROW, control will return +immediately to the CATCH. For example: + CATCH [PRINT 69 THROW PRINT 105] +will only print 69; the PRINT 105 will never be executed. +CATCH takes an optional second argument, called the tag. If CATCH +is given a tag, only THROWs which specify that tag (as their +optional second argument) will "match" the CATCH. Thus: + (CATCH [CATCH [(THROW "FOOTAG )] PRINT 69] "FOOTAG ) +will never print 69, because the inermost CATCH will not trap +the THROW which has specified FOOTAG. A tag can be any +LOGO object that can be used as an input to EQUAL. +THROW also can take an +optional second argument which is the value to be returned by +the CATCH. Since specifing the second argument requires specifing +the first there is a special case check for the empty word as +a tag. If the given tag is the empty word THROW acts as if there +were no tag. So: + PRINT CATCH [(THROW " "FOO )] +will print FOO. Of course, the use of tags can be combined with the +use of returned values. + +When the system starts up it asks for the date and time; the forma is: +YY MM DD HH MM SS +any seperator can be used between the numbers, e.g. 77/12/31 7:32:21 works. +The input is terminated by a carriage return and can be terminated +at any point, e.g. after typing just the date or after typing nothing. +Rubout will cause the question to be asked again. +Currently time and date are not kept on files, but I am +considering putting that in. + + + + + +31 Jan 77 +In version 364 and greater: + +A bug is fixed in PO TREE; it used to skip the printing of certain +files in certain directories; also both POI and PO TREE now count +directories as one block, so that if you SETI to the root and do +a PO TREE and add the number of used and free blocks you will +get exactly the number of blocks available for files (that is, +not including reserved or swap areas) on the disk. + +In the LSI version, a bit table counting bug is fixed. + + +8 May 78 +In version 450 and greater: + +Amazingly enough, no great changes have happened since version 364. +Many INTERNAL changes have happened, however. + +The display stuff has been changed to accomade the new 2500 code. Since +certain things about the new 2500 are different LOGO actually has to interogate +the 2500 to find out if it is a new one or not. There is code to control +the turtle and plotter which can be connected to the 2500. + +The file EVAL (the main "core" of LOGO) knwo only uses the english and french +assembly flags; it also has many of its global symbols so declared, in +preparation for assembling under RT11 and/or UNIX. Also, all storage management +functions have been moved to a new file, STORAG. + +Some things have been swapped around to take advantage of the LSI11 memory +map. The error messages, garbage collection bit table and LSITS disk buffer +are now all kept in high core. "High core" means the top of whatever memory +is accessible; if there is a map that's 48K (or whatever) downward. If there is +no map, 30K downward. In the case of a machine with a map, these things +normally occupy no virtual address space. When they are needed they are mapped +in to the page just above 30K, so in fact they never interfere with the +normal 30K virtual space. + +Things which are on the list for implementation "soon": + push down list in mapped memory + double density disks (all support software done, so this is trivial) + flushing the "quote" meaning of the 200 bit (needed for french characters) + SAFEDISK, a mode where the diskettes are always unmounted when possible + finishing the graceful recovery on disk error stuff + multiple disk buffers + + Meters have been implemented in the LSI version for monitoring +the time spent doing various things. There are two related primitives: +METER and METERGO, both of which take one argument. METER n returns the value +of the nth meter; except for the zeroth meter and the eighth meter, all of the +meters are times in 60ths of a second since the meters were last reset. +METERGO of -1 clears the meters and starts metering. METERGO 1 stops metering +and METERGO 0 starts metering without clearing the meters. Here is the list of +meters: + +0 MTGCCN: .BLKW 2 ;GC COUNT +1 MTCLK: .BLKW 2 ;TIME SINCE METERS ZEROED +2 MTEVAL: .BLKW 2 ;TIME RANDOMLY IN EVAL (NOT IN PRIMITIVES, OR GC) +3 MTPRIM: .BLKW 2 ;TIME SPENT IN PRIMITIVES (BUT NOT IN LSITS OR GC) +4 MTGCOL: .BLKW 2 ;TIME SPENT IN GC +5 MTLSIT: .BLKW 2 ;TIME SPENT IN LSITS (NOT IN TYI OR DISK XFER) +6 MTTYI: .BLKW 2 ;TIME SPENT HANGING AROUND FOR TYPEIN +7 MTDISK: .BLKW 2 ;TIME SPENT DOING REAL DISK TRANSFERS +8 MTDSKC: .BLKW 2 ;COUNT OF DISK XFERS +9 MTSPR1: .BLKW 2 ;SPARE #1 +10 MTSPR2: .BLKW 2 ;SPARE #2 +11 MTFLAG: .BLKW 2 ;IF ZERO, RUN THE METERS +12 to 43 PCMETR: .BLKW 2*32. ;TIME SPENT AT PC, INDEX ON 5 HIGH BITS + +Note that meters 2 through 7 inclusive should add up to meter 1; similarly +meters 12 through 43 inclusive should add to meter 1. + The way the meters work is that several sections of logo set flags +to indicate what logo is doing at that instant. When the clock ticks (once +each 60th of a second) it increments (if the meters are on) the MTCLK meter, +one of the meters 2 through 7 and one of the meters 12 thorugh 43. Note that +this technique results in statistical metering: the meters are rather useless +in figureing out how a short program, run once, spends its time. Probably +a minimum run of 5 minutes or so should be used to get reasonably accurate +numbers from the meters. The meters 2 through 7 indicate how much time +is spent on specific tasks. E.g. if the meters are started and then no +program is run, meter 6 will accumulate all of the time. If the program +TO COLLECT +1 .GCOLL GO 1 +is run, we would expect that meter 4 would accumulate almost all of the +time. Also, each time around the loop meter 0 will be incremented. The program +TO GOTO +1 GO 1 +would cause all the time to be accumulated in meters 2 and 3. +Meters 9 through 41 will give a histogram of where the time is +spent in relation to the high order bits of the program counter. + +A note on changes to the 2500 (new PROM code): + +Bug fixes: + +The problem where CLEARSCREEN sometimes clear commands sent after it +has been fixed. + +Old things changed: + +The character under the cursor is displayed when the cursor blinks off. + +snap, rubdis incompat + +New features: + +The character control-R (ascii 18) is similar to control-Q (ascii 17) +except that control-R adds 128 to the value of the next character. This +has the effect of displaying characters in the high font memory +(e.g. accented characters). + +Turtles and plotters are now supported. There is a command to select which +device to send turtle commands to. Octal 52000 selects the display; 52001 +selects the turtle and 52002 selects the plotter. In addition to the normal +turtle commands, when the (real) turtle is selected the command 4004 will +cause the 2500 to send back a character indicating the touch sensor state; +4001 will turn on its lamps; 4002 will turn them off and 4003 will cause +a toot. The snap command is not useful when running either the turtle or +the plotter. + +18 July 1978 + +In version 490 and greater: a bug has been fixed in .OPENM that caused it to +affect channel zero when .OPENMing on other than channel zero. +The primitive .ENDFILE has been added; it returns the address of the end of +the file open on the specified channel. + +In an attmpt to keep better track of all the software that is flying around, +I have instituted a system of "release numbers". Basically, whenever there +is a version of something that both has a number of new features or bug +fixes and seems to be stable enough it will be assigned a release number +and distributed. The "number" actually can have a letter appended to it +if the only change is minor features/bug fixes. I have arbitrarly decided that +the current release number of LOGO is 2 and all utility software is 3. +When LOGO gets the ability to handle double density diskettes it will +become release number 3 also. (Everything else can handle them now.) +NLOGO directory for release 10 (version 490) +All software will still retain the normal version number also; +eventually released software will type out the release nubmer as +well as the version number. +Release 2 of LOGO is version 490, comprised of the following files: + +AI NLOGO +FREE BLOCKS #1=252 #2=252 #3=252 #4=261 #13=132 #5=250 + 1 COMMON 21 1 6/4/78 14:22:16 + 3 CONTRO 45 7 7/10/78 07:45:11 + 3 DISPLA 18 24 6/4/78 17:30:42 + 4 EVAL 107 34 7/12/78 20:48:13 + 4 FILING 71 8 7/12/78 20:48:10 + L FLOPDF 1 RJL FLOPDF > + 3 GTFUN 74 2 6/4/78 17:38:26 + 4 IMPURE 58 5 6/5/78 19:38:54 + 2 INIT 42 2 5/18/78 16:12:06 + 4 LSFLEM 31 5 11/13/77 11:18:25 + 1 LSFLVR 4 1 11/12/77 16:19:36 + 5 LSITS 94 15 7/10/78 07:45:17 + 1 LSITVR 62 2 6/15/78 12:16:21 + 4 PURE 72 9 7/12/78 20:50:42 + 4 STORAG 13 4 5/29/78 22:35:08 + +The versions of the utility (release 3) software are: + +AI SITS +FREE BLOCKS #1=149 #2=151 #3=99 #4=135 #13=240 #5=152 + 2 SALV 213 16 !7/17/78 21:44:47 + +AI RJL +FREE BLOCKS #1=149 #2=149 #3=99 #4=135 #13=240 #5=152 + 4 BLOADR 101 4 !7/17/78 22:08:06 + 1 BOOT 24 1 5/14/78 00:05:51 + 2 FLOPDF 13 1 4/28/78 20:32:10 + 4 FLOPTS 87 5 !7/17/78 22:07:10 + 4 MAPTST 19 3 5/1/78 23:40:20 + 3 MAPTST BIN 4 5/1/78 21:32:30 + 5 TAPE 101 7 !7/17/78 21:45:54 + +Fixed a bug in the root creation stuff so that if the creation fails the world +recovers gracefully rather than screwing up. This applies both if the BITS file +isn't found and if an attempt is made to mount more than the maximum number +of disks. + +BLOADR 102, R3A will do a reset after writing all (unmapped) memory. This +has the effect of clearing any existing parity errors and turning off the +parity errors indications (provided the memory is good and doesn't cause +any more errors). + +The error numbers, which magically got broken in a previous version, have +been fixed again. + +It is now possible to assemble a version with the abiltity to handle +more than one serial interface; this is useful e.g. for the PROM +programmer or the multiwriter. diff --git a/doc/programs.md b/doc/programs.md index 4bb57d69..2ef3cd6a 100644 --- a/doc/programs.md +++ b/doc/programs.md @@ -317,6 +317,7 @@ - SHELL, Unix-like command line processor. - SHUTDN, shut down ITS. - SITS, Small ITS for the Logo PDP-11/45. +- SLOGO, PDP-11 Logo for SITS. - SN, snoop terminal. - SPCWAR, Spacewar game. - SPEEDY, instruction timing test. diff --git a/src/nlogo/common.23 b/src/nlogo/common.23 new file mode 100755 index 00000000..18228b06 --- /dev/null +++ b/src/nlogo/common.23 @@ -0,0 +1,333 @@ + .TITLE PDP11 LOGO + +.IF NDF PASS2 + +.MACRO DC A,B +A=B +.ENDM + +.MACRO DCS A,B +A=B +.ENDM +;DECIDE ON SITS, UNIX OR LSI + .IF NDF LSI + .IF NDF SITS + .IF NDF UNIX + DC UNIX,0 ;IF NOTHING DEFINED, SITS VERSION + DC SITS,1 + DC LSI,0 + .IFF + DC SITS,0 ;UNIX IS DEFINED, ZERO SITS AND LSI + DC LSI,0 + .ENDC + .IFF + DC LSI,0 ;SITS IS DEFINED, ZERO LSI AND UNIX + DC UNIX,0 + .ENDC + .IFF + DC SITS,0 ;LSI IS DEFINED, ZERO SITS AND UNIX + DC UNIX,0 + .ENDC +.ENDC + +;This used to be in the IF Z UNIX, with a null macro in UNIX. Why? + .MACRO VERSIO + .IIF NDF VERNF,VERNF==0 + .IIF NDF PASS2,VERNF==VERNF+%FNAM2 + .ENDM + +.IF Z UNIX + %COMPAT==0 + .ABS + .MACRO DC VAR,VAL + VAR==VAL + .ENDM + .MACRO DCS VAR,VAL + VAR==VAL + .ENDM + .IFF + .ASECT + .MACRO DC VAR,VAL + VAR=VAL + .ENDM +.ENDC + + .SBTTL MACROS + +VERSIO + + + +A=%0 +B=%1 +C=%2 +D=%3 +E=%4 +F=%5 +U=%5 +P=%6 +SP=%6 +PC=%7 + + +DC FA,%0 +DC FB,%1 +DC FC,%2 +DC FD,%3 +DC FE,%4 +DC FF,%5 + +DC EOFCHR,3 +DC ERROR,200+TRAP + +.XCREF A,B,C,D,E,F,P,PC,FA,FB,FC,FD,FE,FF + +.MACRO SAVE THINGS + .IRP X, + .IFB X + TST -(P) + .IFF + .IF IDN X,#0 + CLR -(P) + .IFF + MOV X,-(P) + .ENDC + .ENDC + .ENDM +.ENDM + +.MACRO REST THINGS + .IRP X, + .IF B X + TST (P)+ + .IFF + MOV (P)+,X + .ENDC + .ENDM +.ENDM + + + +.MACRO BRAKET + TST BRAKE + BEQ .+4 + ERROR+BRK +.ENDM + +.MACRO PUSH ITEM + MOV ITEM,-(P) + JSR PC,PPUSHT +.ENDM + +.MACRO POP ITEM + MOV (P)+,ITEM + JSR PC,PPOPT +.ENDM + +.MACRO PUSHS ITEM + JSR PC,SPUSHT + MOV ITEM,@S +.ENDM + +.MACRO POPS ITEM + MOV @S,ITEM + JSR PC,SPOPT +.ENDM + +.MACRO SPUSH ITEM + MOV ITEM,-(P) +.ENDM + +.MACRO SPOP ITEM + MOV (P)+,ITEM +.ENDM + +.MACRO SPUSHS ITEM + SUB #2,S + MOV ITEM,@S +.ENDM + +.MACRO SPOPS ITEM + MOV @S,ITEM + ADD #2,S +.ENDM + + +.MACRO PRTXT TEX + JSR A,ERTAS + .ASCIZ ÔEXŠ .EVEN +.ENDM + +.MACRO CPRTXT TEX + JSR A,ERTAS + .BYTE 15 + .ASCIZ ÔEXŠ .EVEN +.ENDM + +.MACRO PRTXTC TEX + JSR A,ERTAS + .ASCII ÔEXŠ .BYTE 15,0 + .EVEN +.ENDM + +.MACRO PAD A,B + .PRINT Á B +Š .ENDM + +.MACRO PRCR + JSR PC,.CRLF +.ENDM + +.MACRO SPACE + JSR PC,.SPACE +.ENDM + +.MACRO REPT1 A,B + .REPT A + B + .ENDR +.ENDM + +.MACRO EXCH LOC1,LOC2 + MOV LOC1,EXCH1 + MOV LOC2,LOC1 + MOV EXCH1,LOC2 +.ENDM + +.MACRO NODE A,B +DC $.,$$+1 + A + B +DC $$,$$+1 +.ENDM + + +.MACRO CONS A,B,C + A'B'C' +.ENDM + + + +;THESE DO CONDITIONALIZED LANGUAGE ASSEMBLIES OF THE FORM +; STLANC +; ENGINS +; ENGINS +; . . . +; ENDENG +; FRINS +; FRINS +; ENDLAN + +DC LGNSYM,0 + +.MACRO STLANC +.IFNZ ENG&FR + BIT #PFRFLG,LANG + CONS ,LS,\LGNSYM +.ENDC +.ENDM + +.MACRO ENDENG +.IFNZ ENG&FR + CONS
,LS,\ + CONS LS,\LGNSYM,:: +.ENDC +.ENDM + +.MACRO ENDLAN +.IFNZ ENG&FR + CONS LS,\LGNSYM+1,:: + DC LGNSYM,LGNSYM+2 +.ENDC +.ENDM + +.MACRO ENGINS INS + .IIF NZ ENG,INS +.ENDM + +.MACRO FRINS INS + .IIF NZ FR,INS +.ENDM + + +.MACRO SDPADD HIGH1,LOW1,HIGH2,LOW2 +.IFNB LOW1 + ADD LOW1,LOW2 + ADC HIGH2 +.ENDC +.IFNB HIGH1 + ADD HIGH1,HIGH2 +.ENDC +.ENDM + +.MACRO SDPSUB HIGH1,LOW1,HIGH2,LOW2 +.IFNB LOW1 + SUB LOW1,LOW2 + SBC HIGH2 +.ENDC +.IFNB HIGH1 + SUB HIGH1,HIGH2 +.ENDC +.ENDM + +.MACRO VERR +.IFLE .-.VERR-127. + BVS .VERR +.ENDC +.IFG .-.VERR-127. + BVC .+4 + DC .VERR,. + ERROR+RTB +.ENDC +.ENDM + +.MACRO DPADD HIGH1,LOW1,HIGH2,LOW2 +.IFNB LOW1 + ADD LOW1,LOW2 + ADC HIGH2 + VERR +.ENDC +.IFNB HIGH1 + ADD HIGH1,HIGH2 + VERR +.ENDC +.ENDM + +.MACRO DPSUB HIGH1,LOW1,HIGH2,LOW2 +.IFNB LOW1 + SUB LOW1,LOW2 + SBC HIGH2 + VERR +.ENDC +.IFNB HIGH1 + SUB HIGH1,HIGH2 + VERR +.ENDC +.ENDM + +.MACRO DPCLR HIGH,LOW + CLR HIGH + CLR LOW +.ENDM + +.MACRO DPINC HIGH,LOW + DPADD ,#1,HIGH,LOW +.ENDM + +.MACRO DPDEC HIGH,LOW + DPSUB ,#1,HIGH,LOW +.ENDM + +.MACRO DPNEG HIGH,LOW + NEG LOW + ADC HIGH + NEG HIGH +.ENDM + +.MACRO NOP NUM + .IFG NUM + BR .+ + NOP + .ENDC +.ENDM + diff --git a/src/nlogo/contro.81 b/src/nlogo/contro.81 new file mode 100755 index 00000000..4c61dda0 --- /dev/null +++ b/src/nlogo/contro.81 @@ -0,0 +1,1700 @@ + + + VERSIO + .SBTTL INITIALIZE NODE SPACE +INIT: MOV #ZEROS,A + MOV #/2,B +4$: CLR (A)+ + SOB B,4$ + MOV #'?,PRMTCH + MOV #27.,RNSEED + MOV IS,S + MOV #UHCT,A ;CLEAR OUT THE USER HASH TABLE + MOV #HCC,B ;THUS MAKING EVERYTHING GARBAGE +1$: CLR (A)+ + SOB B,1$ + MOV #GCMKL,A ;CLEAR ALL THE THINGS THAT GET MARKED ON +2$: MOV (A)+,B + BEQ 3$ + CLR (B) + BR 2$ +3$: +.IFNZ LSI + MOV #NODESP+2000,ARYAD + CLR ASPACE ;RESET ARRAY PARAMETERS + CLR AROVER + CLR AFREE + MOV #NODESP+2000,ARTOP +.ENDC + MOV #NODESP,A + MOV #INODES,B + MOV #400,C + MOV #IDLE,D +INODCP: MOV (B)+,(A)+ + MOV (B)+,(A)+ + DEC C + INC D + CMP #ASOFN,B + BNE INODCP + MOV #NODESP+<400*4>,NODTOP + JSR PC,.GCOLL + RTS PC + +INIT1: BIS #PADERF,FLAGS2 ;SO OCTAL ERROR ADDR IS PRINTED +STARTF: RTS PC +.IFNZ LSI +SINIT: MOV #INITTB,A +.IFNZ LSMAP + TST GOTMAP ;HAVE WE GOT A MAP? + BEQ 2$ ;NOPE + MOV HGHPAG,B ;HIGHEST PAGE +3$: MOV (A)+,C ;SIZE OF THE THING BEING ALLOCATED + ADD #1777,C + BIC #1777,C ;MAKING IT AN EVEN NUMBER OF PAGES + ASH #-10.,C ;PAGES + SUB C,B + MOV B,@(A)+ + CMP A,#INITMP ;AT END OF MAP PART? + BNE 3$ + BIT #177700,B ;DO WE HAVE MORE THAN 32K LEFT? + BNE 2$ + ASH #10.,B ;GET THE REMAINDER IN BYTES + CMP B,MEMTOP ;DO WE HAVE MORE THAN WE WILL USE? + BHIS 2$ ;YUP + MOV B,MEMTOP ;DON'T USE MORE THAN WE HAVE +2$: +.ENDC + MOV MEMTOP,B +1$: SUB (A)+,B + MOV B,@(A)+ + CMP A,#INITTE + BNE 1$ + RTS PC + +EINIT: MOV #ERTXT,A ;POINTER TO THE TEXT + MOV RERTXT,B ;POINTER TO WHERE IT WILL REALLY GO + MOV #ERTXTL/2,C +.IF NZ LSMAP + TST GOTMAP + BEQ 1$ + MOV #MAPON!MAPHCK,MAPCSR + MOV B,MAPADR +3$: MOV #512.,D + MOV #MAPHCA,B +4$: MOV (A)+,(B)+ + DEC C + BLE 6$ ;DONE + SOB D,4$ ;DONE PAGE? + INC MAPADR + BR 3$ ;NEXT PAGE +1$: +.ENDC + +2$: MOV (A)+,(B)+ + SOB C,2$ +6$: RTS PC + +MEMCHK: SAVE 4 + MOV #MEMCH1,4 + MOV #CODEND,A +1$: TST (A)+ + BR 1$ + +MEMCH1: CMP (P)+,(P)+ + TST -(A) + MOV A,RMEMT + SUB #40,A ;LEAVE ROOM FOR LSI DDT + MOV #MEMCH2,4 ;NOW CHECK FOR 11/45 + TST 177772 ;pirq? + MOV #156400,MEMTOP ;WE ARE ON 11/45, LEAVE ROOM FOR RUG + CLR GOTSMS ;NO SMS + CLR GOTMAP ;AND NO LSI STYLE MAP + BR MEMC11 ;GO CHECK FOR LPT +MEMCH2: CMP (P)+,(P)+ ;FLUSH THE TRAP +MEMCH3: MOV A,MEMTOP +.IFNZ FILDSK!TIMCLK + MOV #MEMCH4,4 ;NOW CHECK FOR SMS + BIS #SMSRSB,SMSCSR ;IF WE HAVE ONE, RESET IT + MOV PC,GOTSMS ;GOT ONE + CLR SMSLGT +.IFNZ TIMCLK + MOV #30.,HSEC ;DEFAULT IS 60HZ +.IF NZ SMSDSK + BIT #SMS60H,SMSPRE ;IS THIS A 60HZ MACHINE? + BNE 1$ ;YUP + MOV #25.,HSEC ;NOPE, MUST BE A 50 +.ENDC +1$: BR MEMCH5 +MEMCH4: CMP (P)+,(P)+ +MEMCH5: +.ENDC +.ENDC +.IFNZ LSMAP + MOV #MEMCH8,4 + CLR GOTMAP + CLR MAPCSR + MOV PC,GOTMAP + MOV #8.,A ;WE ARE GOING TO ASSUME 4K RESIDENT +1$: MOV #777,MAPADR ;WE ASSUME THIS IS NON-EX + INC MAPCSR + SOB A,1$ + MOV #64.-8.-4.,A ;OF 64 PAGES, 8 ARE RESIDENT MEM AND 4 ARE I/O + CLR B + BIT #100,MAPCSR ;IF THIS BIT IS CLEAR, WE HAVE RESIDENT MEM + BEQ 2$ + ADD #8.,A + CLR MAPCSR ;SET BOTTOM 4K TOO +2$: MOV B,MAPADR + INC B + INC MAPCSR + SOB A,2$ + MOV #4,A ;NOW ABOUT THAT I/O SPACE... +3$: MOV #777,MAPADR + INC MAPCSR + SOB A,3$ + MOV #MEMC10,4 + MOV #MAPON!MAPHCK,MAPCSR ;THE HACK PAGE + CLR MAPADR +4$: TST MAPHCA + INC MAPADR + BR 4$ +MEMC10: CMP (P)+,(P)+ + MOV MAPADR,HGHPAG ;HIGHEST EXTANT PAGE+1 + DEC HGHPAG + BR MEMC11 +MEMCH8: CMP (P)+,(P)+ +MEMC11: +.ENDC +.IFNZ LSPRNT + MOV #MEMCH6,4 + TST LPS ;IS THERE A PRINTER? + BR MEMCH7 +MEMCH6: CLR LPUSE ;"USED" +.IIF GT LSTTY-1, MOV #1,MWTTY ;MUST HAVE A MULTIWRITER, IF WE HAVE ANYTHING + CMP (P)+,(P)+ +MEMCH7: +.ENDC + REST 4 + RTS PC + +HINIT: BIS #100,LSRCS0 ;TTY INTERUPTS + MOV #LSITRP,LSITRV +.IIF NZ LSDISK, CLR LSDKOF ;DISK GOT TURNED OFF +.IFNZ LSCLK + TST GOTSMS + BEQ 1$ + BIS #SMSCLE,SMSCSR ;ENABLE CLOCK TOO +1$: +.ENDC +.IFNZ LSMAP + TST GOTMAP + BEQ 2$ + BIS #MAPON,MAPCSR +2$: +.ENDC + RTS PC + +.ENDC + + .SBTTL READ-EVAL LOOP DRIVER (THE ONE-USER MAIN LOOP) +.IFNZ LSI +PURIFY: MOV #RSTPDL,P + JSR PC,SORT + JSR PC,SYSCHK ;TO INIT XORS BEFORE DUMPING + HALT +.ENDC + +START: +.IFNZ LSI + RESET +.ENDC + MOV #.TICTM!.TIECM!.TLIPM!.TICVM,TTYST + MOV #TYO,PCHR + MOV #TYI,GCHR + TST RAN ;DID WE EVER RUN? + BEQ 2$ ;NOPE + JMP RESTART ;EITHER WE ARE A RELOADED DUMP OR A RESTARTED LIVE PROGRAM +2$: MOV PC,RAN ;NEXT TIME WE WON'T GET TO HERE +.IFNZ LSI + MOV #RSTPDL,P + JSR PC,MEMCHK ;CHECK AMOUNT OF MEMORY + JSR PC,SORT ;SORT THE SYSTEM OBLIST + JSR PC,SINIT ;INIT STORAGE + JSR PC,EINIT ;INIT THE ERRORS +.ENDC +START1: +.IFNZ LSI + MOV #RSTPDL,P + JSR PC,SINIT ;INIT STORAGE + MOV IP,P ;INIT P PDL + JSR PC,HINIT ;INIT ANY HARDWARE THAT NEEDS IT + JSR PC,SYSCHK ;SET UP THE SYSTEM CHECKSUMS +.IIF NZ TIMCLK, JSR PC,GETTIM + JSR PC,LSINIT ;INIT THE LITTLE SITS EMULATOR +.IFF + MOV IP,P ;INIT P PDL +.ENDC + +.IFNZ TS + + TST INITED ;HAS THE PURIFYING ALREADY BEEN DONE? + BNE 1$ + JSR PC,PURINT +1$: + SPUSH #0*400+0 ;LENGTH AND START + TST -(P) ;PAGE TO GET NOT USED WITH SOURCE=FRESH + SPUSH #<10+NODPG>*400+377 ;40000-60000, FRESH PAGE + SPUSH #<.CRWRT+1> ;INSERT INTO SELF + $MAP +.ENDC + JSR PC,SETTTY +.IIF NZ DSK, JSR PC,DSKINT +.IIF NZ SITS, JSR PC,BRKINT ;SET UP THE BREAK PROCESS +.IIF NZ TVS, JSR PC,TVCHK ;SET THE TV FLAG +.IF NZ FPPF +.IIF NZ SITS, $FLOAT + LDFPS #40300 +.ENDC + JSR PC,INIT +.IIF NZ SITS, JSR PC,RINIT + JSR PC,HELMES + JMP MLOOP + +RESTAR: MOV #RSTPDL,P ;TEMP PDL +.IFNZ SITS + SAVE <,,#.SPKIL*400+1> ;KILL ALL PROCESSES BUT ME + $INVOK + MOV MAINPR,A ;MAIN PROCESS + JSR PC,DELCP ;DELETE IT + $SINK ;I WILL BECOME THE BREAK PROCESS, DON'T NEED FLOATING POINT + JSR PC,BRKINT ;MAKE SURE BREAK PROCESS IS RUNNING + $FLOAT ;MAKE SURE WE HAVE FLOATING POINT +.IFF + JSR PC,HINIT +.ENDC +.IIF NZ TVS,JSR PC,TVCHK ;SET UP TV'S + LDFPS #40300 + JMP TOPLEVEL ;GO TOP LEVEL US +1$: BPT ;DOESN'T WORK + +HELMES: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + MOV LVERNF,A + JSR PC,PRDN +.IIF NZ LSI, PRTXT ^/ R3D/ + TST DEBSW + BEQ 1$ ;IF DEBUG SWITCH IS ON + ;PRINT MESSAGE + CPRTXT ^/LOGO being debugged!/ +1$: PRCR ;PRINT CR + RTS PC + +.IFNZ SITS ;LSITS HANDLES ALL THIS DIFFERENTLY +DSKINT: + SAVE <#PSWPAD,#-PPDLL> ;KLUDGE, TEHSE ARGS FOR BLKO + SAVE <#-1,#PCRBLK,#.FACAP*400+0> ;THESE ARGS FOR THE INVOKE + $INVOK + MOV (P),PPDLCP + $BLKO ;RESEVRE THE EMERG BLOCK + SAVE <#SSWPAD,#-SPDLL> ;ARGS FOR BLKO + SAVE <#-1,#SCRBLK,#.FACAP*400+0> ;ARGS FOR INVOK + $INVOK + MOV (P),SPDLCP + $BLKO ;FOR EMRG BLOCK + MOV #10,DEFROT ;IF NO DEFAULT, 10 IS THE DEFAULT + MOV #4,DEFCAP + SAVE <#0,#4,#<1*400>+1> + $INVOK ;READ THE C-LIST AT 4 (DEFAULT DIR) + TST (P)+ ;IS ANYTHING THERE? + BNE HAVDEF ;YES, WE HAVE A DEFAULT DIR. + SAVE <#-1,#0,#.CPYCP+10> ;NO DEFAULT DIRECTORY, + $INVOK ;SO USE THE ROOT + SPOP DEFCAP +HAVDEF: SAVE <,,DEFCAP> + BIS #.FADI,(P) ;WANT TO GET DISK NUMBER + $INVOK + REST ;DISK NUMBER IS SECOND ON STACK + ADD #10,A ;CONVERT TO ROT CAP NUMBER + MOV A,DEFROT ;THIS IS THE DEFAULT ROOT + MOV #10,C ;FIRST DISK CAP + CLR A + CLR DISKS +DSKNAM: SAVE <#DNAME,#<4+MXNAME>*2,C> + BIS #.FARI,(P) ;WANT TO GET DISK NAME + .INVOK + BEQ OPNDON ;IF IT FAILS WE MUST BE DONE + INC DISKS ;ONE MORE DISK + MOV DNAMEP(A),E ;POINTER TO NAME BLOCK + MOV #DNAM,F ;POINTER TO NAME READ IN +1$: MOVB (F)+,(E)+ + BNE 1$ + ADD #2,A ;NEXT DISK NUMBER + INC C ;POINT TO THE NEXT CAPABILITY + BR DSKNAM +OPNDON: CLR (A) ;TERMINATE DISKS + ADD #6,P ;FIX PDL + RTS PC +.ENDC + +.IF NZ SITS +BRKINT: SAVE <#-1,#BRKIN1,#.PRCAP*400+0> + $INVOK ;CREATE THE MAIN PROCESS + REST MAINPR ;SAVE CAP TO IT + SAVE <,MAINPR,#<.SPPTP*400>+1> + $INVOK ;PUT PROCESS INTO OURSELF + MOV P,A ;PDL FOR MAIN PROCESS + SAVE <,A,MAINPR> + BIS #<.PRREG!.PRWRT!6>*400,(P) ;WRITE PDL POINTER + $INVOK + SAVE <,#0,MAINPR> + BIS #<.PRSTOP!.PRWRT>*400,(P) + $INVOK ;START MAIN PROCESS + BR BRKPRS ;WE AR ETHE BREAK PROCESS + +BRKIN1: RTS PC ;MAIN PROCESS RETURNS + +EBREAK: ERROR+BRK ;CLOBBER THE MAIN PROCESS TO COME HERE IF HUNG + +BRKPRS: MOV #BRKPDL,P ;MY OWN SPECIAL PDL +BRKPR3: SAVE <#0,#<'Z-100>*400+'G-100,TYICP> + MOVB #.TTBRK,1(P) ;TO WAIT FOR ONE OF THESE CHARS + $INVOK ;WAIT + CMPB #'Z-100,(P) ;WAS IT A PAUSE? + BNE BRKPR1 + MOV #-1,BRAKE +BRKPR1: CMPB #'G-100,(P) ;WAS IT A BREAK? + BNE BRKPR2 + MOV #1,BRAKE +BRKPR2: TST (P)+ + TST BRAKE + BEQ BRKPRS + SAVE <,#1,MAINPR> + BIS #<.PRSTOP!.PRWRT>*400,(P) ;WANT TO STOP THE MAIN PROCESS + $INVOK + SAVE <,,MAINPR> + BIS #<.PRREG+7>*400,(P) ;WANT TO READ IT'S PC + $INVOK + MOV #BREAKS,A ;TEHMS THE BREAKS +2$: CMP (P),(A) ;IS THE PC THERE? + BEQ 1$ ;YUP + TST (A)+ ;NEXT + BNE 2$ + BR BRKPR4 +1$: SAVE <,#EBREAK,MAINPR> + BIS #<.PRREG+7+.PRWRT>*400,(P) + $INVOK +BRKPR4: TST (P)+ ;POP PC + SAVE <,#0,MAINPR> + BIS #<.PRSTOP!.PRWRT>*400,(P) + $INVOK + SAVE <,#.TIRST!.TORST,TYICP> + MOVB #.TTBIS,1(P) + $INVOK ;RESET TTY INPUT AND OUTPUT + BR BRKPR3 +.ENDC + +.IFNZ TS +PURIFY: MOV IP,P + JSR PC,PURINT + SAVE <#7_8.+0,,#<20+PURPG>_8.+374,#.CRRD+1> + $MAP ;MAKE PURE CONSTANTS PURE + MOV #PURPG+1,A ;FIRST I SPACE ONLY PAGE + MOV #<&77>-<*8.>,B ;NUMBER OF 512 WORD BLOCKS OF CODE +PURLOP: SAVE <#7_8.+0,,#374> + MOVB A,1(P) ;THE PAGE NUMBER + SAVE <#.CRRD+1> ;ACCESS DESIRED AND SPHERE CAP + SUB #10,B ;ABOUT TO HACK THIS MANY BLOCKS + BLT PURLP1 ;WE ARE ON LAST PAGE + INC A ;NEXT PAGE + $MAP ;MAKE PAGE READ ONLY + BR PURLOP +PURLP1: ADD #10,B ;GET LENGTH FOR LAST PAGE + MOVB B,7(P) ;CLOBBER LENGTH + $MAP ;PURIFY AND SHORTEN LAST PAGE + MOV PC,INITED + CLR DEBSW + BPT + JMP START + +PURINT: MOV #PURPG+1+10,A +DELPAG: CMP -(P),-(P) ;IN DELETE, NOT USED + SAVE #-3 ;DELETE FUNCTION + MOVB A,1(P) ;WHICH PAGE + SAVE #1 ;SELF + $MAP ;BETTER NOT FAIL! + INC A + BIT #7,A ;LAST PAGE DONE? + BNE DELPAG + SAVE <#LSUPBL_8.+0,,#20_8.+374,#.CRWRT+1> ;SHRINK PAGE 0 + $MAP + JSR PC,SORT + RTS PC + +;THE EXPAND SPACE ROUTINE +;CALL WITH A POINTER IN A TO A BLOCK: +;(A) CURRENT HIGHEST PAGE +;2(A) CURRENT LENGTH OF HIGHEST PAGE +;4(A) HIGHEST PAGE TO USE FOR THIS SPACE +;MAY CLOBBER B AND C +EXSPAC: TST HALLIM ;HAVE WE ALREADY GOT ALL THAT'S ALLOWED? + BEQ EXSPA3 + INC 2(A) ;INCREASE HIGH PAGE? + CMP #10,2(A) ;IS IT ALREADY 4K? + BEQ EXSPA1 ;YUP + SAVE <#0,#0,#10_8.+374,#.CRWRT+1> ;TO EXPAND THE PAGE + MOVB 2(A),7(P) ;HOW LONG? + BISB (A),3(P) ;WHICH PAGE? + .MAP ;ATTEMPT TO EXPAND + BNE EXSPA2 ;LOSE? + ADD #10,P ;POP ARGS OF FAILED CALL + DEC 2(A) ;WE DIDN'T DO WHAT WE SET OUT TO +EXSPA3: SEZ ;INFORM OF FAILURE + RTS PC +EXSPA2: DEC HALLIM + CLZ + RTS PC +EXSPA1: DEC 2(A) ;NOT INCREASING PAGE SIZE AFTER ALL + CMP (A),4(A) ;ALREADY ON LAST PAGE? + BEQ EXSPA3 ;IF YES LOSE + INC (A) ;GO TO NEXT PAGE + CLR 2(A) ;START WITH 512 WORDS + SAVE <#0,#0,#10_8.+377,#.CRWRT+1> ;TO CREATE NEW PAGE + BISB (A),3(P) ;WHICH PAGE? + .MAP ;TRY TO CREATE + BNE EXSPA2 ;BR ON WINNING + ADD #10,P ;POP ARGS + MOV #7,2(A) ;BACK UP + DEC (A) ;TO PREVIOUS PAGE + BR EXSPA3 ;GO FAIL +.ENDC + +GOODBYE: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN +.IF NZ SITS + IOT +.IFF + JSR PC,LOGBYE ;CLEAN UP + JSR PC,ONETYI + JMP START1 +.IFT + CPRTXT ^/YOU BACK AGAIN???/ + SEZ + RTS PC +.IFF +LOGBYE: +.IIF NZ CPF, JSR PC,PRTOFF +.IFNZ FILDSK + JSR PC,FLSDEF + JSR PC,DELCPS + JMP DELALC ;TWO TRYS SHOULD GET ALL OF THEM (I HOPE) +.ENDC +.ENDC + RUNRUG: JSR PC,CKSST + BPT +SRTS: SEZ + RTS PC + +.IF Z UNIX +TSSET: TST -(P) + SPUSH D + SPUSH #.TTMOV*400+2 ;SET THE TTY STATUS + $INVOK + BR SRTS +.IFF +TSSET: MOVB D,SGFLAGS ;STORE FLAGS WE WANT IN ARG BLOCK + BISB #EVENP!ODDP!CRMOD,SGFLAGS ;ALWAYS SET THESE BITS + SYS IOCTL + 0 ;FILE DESCRIPTOR FOR TTY INPUT + TIOCSETP + SGTTYB ;POINTER TO ARG BLOCK + BR SRTS +.ENDC + +.IF Z UNIX +.SETLI: JSR PC,G1NARG + SAVE <,B,#.TTSLN*400+2> + $INVOK + BR SRTS +.ENDC + +.IFNZ LSPRNT +.SETLP: JSR PC,G1NARG + MOV B,LPLEN + BR SRTS + +.LPLCN: DEC D + BLT 1$ ;NO ARG, JUST RETURN + BEQ 2$ + ERROR+WNA +2$: JSR PC,G1NARG + MOV B,LPLCNT ;SET THE LINE COUNT + BR SRTS ;and return no value +1$: MOV LPLCNT,B + JMP R1NARG +.ENDC + +SETTTY: SAVE D + MOV TTYST,D +SETTT1: JSR PC,TSSET + REST D + BR SRTS + +WHERE: JSR PC,GETCNO + JMP R1NARG + +.IF Z UNIX +GETCNO: SAVE <,,#.TTCNO*400+2> + $INVOK + REST B ;CONDITION CODES SET HERE USED BY INPUTL + RTS PC +.IFF +GETCNO: CLR B ;*** UNIX NEEDS THIS FEATURE! *** + RTS PC +.ENDC + +TINECH: SAVE D +.IIF Z UNIX, MOV #.TLIPM!.TICVM,D +.IIF NZ UNIX, MOV #LCASE,D ;NO ECHO, BUT NO CBREAK + BR SETTT1 + +ECHOSW: +.IIF Z UNIX, MOV #.TIECM,C +.IIF NZ UNIX, MOV #ECHO,C + BR CASES1 +CASESW: +.IIF Z UNIX, MOV #.TICVM,C +.IIF NZ UNIX, MOV #LCASE,C +CASES1: JSR PC,G1NARG + CLR A + TST B + BEQ 1$ + MOV C,A +1$: BIC C,TTYST + BIS A,TTYST + JMP SETTTY +.IFNZ TVS +TVTEST: BIT #TVF,DFLAGS + BNE 1$ + ERROR+OTVS +1$: RTS PC + +.TVP: BIT #TVF,DFLAGS + BEQ 1$ + JMP RTTRUE +1$: JMP RTFALS + +MEDFON: MOV #2,A + BR BIGFO1 +SMALLF: MOV #1,A + BR BIGFO1 +BIGFON: MOV #0,A +BIGFO1: JSR PC,TVTEST + SAVE <,A,TYICP> + BIS #.TVFNT*400,(P) + .INVOK + BNE 1$ + ERROR+WTA +1$: BIT #DISPF,DFLAGS,DFLAGS ;IS DISPLAY TURNED ON? + BEQ 2$ ;NOPE + JMP TVSTR1 ;GO INIT TV +2$: JMP KILLD9 ;GO RECOMUTE ECHO AREA WITH NO DISPLAY + +.ENDC +.IFNZ TIMCLK +CLOCK: +.IFZ UNIX + SAVE <#SSTATS> ;THE SYSTEM STATUS BLOCK + $SSTATUS ;FILL IT UP + MOV STIME,B + MOV STIME+2,A +.IFF + SYS FTIME ;GET TIME FROM UNIX + #.FTIME ;BUFFER TO PUT IT IN + MOV .MSTIM,B ;A IS R0 IS EVEN + CLR A ; AND LOW-ORDER PART IS IN A+1 + MUL #74,A ; SO THIS GIVES TWO-WD RESULT + DIV #1750,A ;MS TIMES 60. OVER 1000. = TICKS + MOV A,.MSTIM ;SAVE THIS TEMPORARILY + MOV .STIM2,B ;WHOLE SECONDS IN B WHICH IS ODD + CLR A ;MAKE IT DOUBLE-LENGTH AGAIN + MUL #74,A ; THIS PUTS TICKS IN A AND B + ADD B,.MSTIM ;ADD LOW PARTS + ADC A ;GOBBLE CARRY BIT + MOV A,.STIM2 ;STASH THIS AWAY + MOV .STIM1,A ;GOBBLE HIGH TIME + CLR B + MUL #74,A ;SIGH + ADD .STIM2,A ;THIS IS TOTAL HIGH PART + MOV .MSTIM,B ;THIS IS LOW PART +.ENDC + JSR PC,GRBAD ;MAKE NODE UP WITHT THE NUMBER IN IT + BIS #INUM,C ;POINT TOT HE NUMBER + JMP ORTC ;RETURN IT + +UTIMEG: MOV #HOUR+2,D + BR UTIME1 +UDATEG: MOV #YEAR+2,D +UTIME1: MOV #SECOND,E + MOV #6,F +1$: CLR (E)+ + SOB F,1$ + SAVE #SECONDS + MOV #3,F + .TIME +UTIME2: MOV -(D),B + JSR PC,PSHNUM + SOB F,UTIME2 + MOV #3,D + JMP SENT. + +.GLOBL WTA ;002 +.IFZ UNIX +SETTV: MOV #SECOND,A + MOV #6,B +1$: CLR (A)+ + SOB B,1$ + JSR PC,G1IARG + SPUSH C + BLT SETTV1 + JSR PC,G1IARG + TST C + BLT SETTV1 + CMP #6,C + BLE SETTV1 + ASL C + BIS #100000,(P) + MOV (P)+,SECOND(C) + SAVE <#SECOND> + .TIME +SETRT: SEZ + RTS PC +SETTV1: ERROR+WTA +.ENDC + +UWAIT: JSR PC,G1IARG +.IFZ UNIX + SAVE +.IFF + DIV #74,B ;TICKS INTO SECONDS (ALL THE PRECISION WE GET) + MOV B,A ;*** CONSIDER CHANGING DOCUMENTATION TO SECONDS INPUT *** + TST A + BGT 1$ ;OK IF POSITIVE + MOV #1,A ;ELSE WAIT AT LEAST 1 SEC +1$: SAVE + SYS SIGNAL ;PREPARE TO IGNORE SIGNAL + 14 ;SIGALRM + 1 ;ODD NUMBER MEANS IGNORE + REST + SYS ALARM + SYS PAUSE + SEZ + RTS PC +.ENDC +SLWAIT: +.IFZ UNIX + $SLEEP +.IFF + SYS SIGNAL ;MAKE SURE WE'RE STILL CATCHING ALARMS + 14 + 1 + CLR A + SYS ALARM ;SEE WHAT CLOCK SAID + BLE 2$ ;BRANCH IF ALREADY TIMED OUT + SYS ALARM ;RESTORE ALARM CLOCK + SYS PAUSE +.ENDC + SEZ + RTS PC +.ENDC + +.IFNZ FILDSK!MULTTY +DELCP: +DELCAP: TST A + BEQ DELCP1 + CMP -(P),-(P) + SAVE A + BIS #.DELCP,(P) + .INVOK + BNE DELCP1 + ERROR+GDE +DELCP1: RTS PC +.ENDC + .SBTTL LOGO TYI/O +ONETYI: +.IIF Z UNIX, MOV #.TICVM!.TIECM,D +.IIF NZ UNIX, MOV #LCASE!ECHO!CBREAK,D + JSR PC,TSSET + JSR PC,TYI ;GET THE CHARACTER + JSR PC,SETTTY + RTS PC + +.IF Z UNIX +CTYI: JSR PC,SAVTTY + TST -(P) + SPUSH #.TLIPM+.TIEDM+.TIRBM + SPUSH TYICP + BISB #.TTBIC,1(P) + $INVOK + SPUSH TYICP +TYWAIT: $BYTI + JSR PC,RESTTY + SPOP B + JMP R1NARG +.IFF +CTYI: JSR PC,SAVTTY + SAVE D + MOV SGFLAGS,D ;GET EXISTING TTY FLAGS + BIS #CBREAK,D ;CHAR AT A TIME MODE + JSR PC,TSSET + REST D +TYWAIT: CLR A ;FILDES FOR STANDARD INPUT + SYS READ + #RDBYTE + #1 ;READ ONE BYTE + JSR PC,RESTTY + MOV RDBYTE,B + JMP R1NARG +.ENDC + +CTYO: JSR PC,G1NARG ;GET ARGUMENT IN B +CTYO1: JSR PC,SETTIM ;SET TTY TO IMAGE MODE +.IF Z UNIX + SPUSH B + SPUSH TYICP + $BYTO +.IFF + MOV B,RDBYTE + MOV #1,A ;FILDES FOR STANDARD OUTPUT + SYS WRITE + #RDBYTE + #1 +.ENDC + JSR PC,RESTTY + SEZ + RTS PC + +SETTIM: JSR PC,SAVTTY +.IF Z UNIX + TST -(P) + SPUSH #.TIMGO ;IMAGE OUT + SPUSH TYICP + BISB #.TTBIS,1(P) + $INVOK +.IFF + SAVE D + MOV SGFLAGS,D + BIS #RAW,D + JSR PC,TSSET ;TOO BAD WE CAN'T HAVE IMAGE OUT WITHOUT IMAGE IN + REST D +.ENDC + RTS PC + +.IF Z UNIX +RESTTY: TST -(P) + SPUSH TTYST + SPUSH TYICP + BISB #.TTMOV,1(P) + $INVOK + SEZ + RTS PC + +SAVTTY: SUB #4,P + SPUSH TYICP + BISB #.TTRD,1(P) + $INVOK + SPOP A + MOV A,TTYST + RTS PC +.IFF +RESTTY: SAVE D + MOV TTYST,D + JSR PC,TSSET + REST D + SEZ + RTS PC + +SAVTTY: SYS IOCTL + #0 + #TIOCGETP + #SGTTYB + MOV SGFLAGS,TTYST + RTS PC +.ENDC + TYI: +.IIF Z UNIX, SPUSH TYICP +.IIF NZ UNIX, CLR A ;UNIX STANDARD INPUT FILDES +RLWAIT: +.IF Z UNIX + $BYTI + SPOP D +.IFF + SYS READ + #RDBYTE + #1 + MOV RDBYTE,D +.ENDC + RTS PC + +TYO: + TST BRAKE + BNE DTYO1 + JSR PC,@DRIBF ;GO TO DRIBBLE ROUTINE IF DRIBBILING +DTYO: +.IF Z UNIX + SPUSH D + SPUSH TYOCP + $BYTO +.IFF + MOV D,RDBYTE + MOV #1,A ;UNIX STANDRD OUTPUT FILDES + SYS WRITE + #RDBYTE + #1 +.ENDC +DTYO1: RTS PC +.SPACE: SAVE D + MOV #' ,D +.SPAC1: JSR PC,@PCHR + REST D + RTS PC + +.CRLF: SAVE D + MOV #15,D + BR .SPAC1 + +EDITA: +.IF Z UNIX + TST -(P) ;DUMMY ARG + SAVE <#.TIEDM!.TERST,#.TTBIS_8.+2> + $INVOK ;RESET EDIT BUFFER AND ENTER EDIT MODE +.ENDC ;NO SUCH FEATURE IN UNIX (YET!) + RTS PC + +ETYO: +.IF Z UNIX + TST BRAKE + BEQ 1$ + RTS PC +1$: SPUSH D + SPUSH TYOCP + BIS #.TTEDM,(P) ;SAY IT SHOULD BE WRITTEN INTO THE EDIT BUFFER + $BYTO +.ENDC ;NO UNIX LINE EDITOR + RTS PC + + +.IFNZ GTL +.GTLOUT: JSR PC,G1NARG + JSR PC,GTOUT + SEZ + RTS PC + +GTOUT: SAVE + JSR PC,SETTIM + CLR A + ASL B + MOV #3,D + MOV #GTLBUF+1,E +GTOUT1: ASHC #5,A + BIC #177740,A + ADD #100,A + MOVB A,(E)+ + SOB D,GTOUT1 +.IF Z UNIX + SAVE <#GTLBUF,#-4,TYOCP> + $BLKO +.IFF + MOV #1,A + SYS WRITE + #GTLBUF + #4 +.ENDC + JSR PC,RESTTY + REST + RTS PC +.ENDC +.IF NZ SITS +.HISSP: JSR PC,GETTTT + BEQ MYSPE1 + MOVB TTYCPS(E),D + BR SETSPD + +MYSPEE: JSR PC,G1NARG +MYSPE1: MOV TYOCP,D + +SETSPD: BIC #177760,B + MOV B,C + ASH #4,C + BIS B,C + ASH #6,C + BIS #3,C + CMP #3,B + BLT 1$ + BIS #4,C +1$: SAVE <,C,#.TTSPD*400> + MOVB D,(P) + .INVOK + BNE 2$ + ERROR+TDE +2$: SEZ + RTS PC +.ENDC + +.IF NZ MULTTY +UGTTYG: POPS E ;DEVICE SPEC (NAME OR NUMBER) + JSR PC,DEVNUM ;E _ TTY NUMBER (OR ERROR IF INVALID NAME) + JSR PC,OPEN1 + RTS PC + +.TTYP: JSR PC,UGTTYG + BEQ TTYP ;SPECIFIED HIS TTY + CMP -(P),-(P) + MOVB TTYCPS(E),-(P) + BR TTYP1 +.ENDC + +.IF Z UNIX +TTYP: CMP -(P),-(P) + SAVE TYICP +TTYP1: MOVB #.TTPEK,1(P) + $INVOK ;FIND OUT IF THERE IS A CHARACTER + TST (P)+ ;NEGATIVE IF NONE + BGE 1$ ;YES RETURN TRUE + JMP RTFALS +1$: JMP RTTRUE +.ENDC + +.IF NZ LSI&LSPRNT +.DIAB: JSR PC,G1NARG + MOV B,F + JSR PC,G1NARG + MOV F,DIBSPS + MOV B,DIBLFS + SEZ + RTS PC +.ENDC + +.IF NZ MULTTY + +;DEVTYI-- TYI N OUTPUTS A CHAR FROM TTY N +DEVTYI: JSR PC,UGTTYG + BNE 1$ ;ANOTHER TTY + JMP CTYI ;WANTED IT FROM HIS TTY +1$: CLR -(P) + MOVB TTYCPS(E),(P) ;CAP WE HAVE TO THE TTY +DTWAIT: $BYTI ;GET A BYTE + REST B ;FOR THE USER + JMP R1NARG + +;DEVTYO-- TYO N M SENDS CHAR M TO TTY N. N MAY BE NAME OR NUMBER. +DEVTYO: JSR PC,GETTTT + BNE 1$ + JMP CTYO1 +1$: SAVE + MOVB TTYCPS(E),(P) ;OUR CAP TO THIS TTY + $BYTO +RTSPC: SEZ + RTS PC + +GETTTT: JSR PC,G1NARG ;B _ CHAR + POPS E ;DEVICE SPEC + JSR PC,DEVNUM ;E _ TTY NUMBER (OR ERROR IF INVALID NAME) + JSR PC,OPEN1 ;MAKE SURE TTY OK + RTS PC + +.IIF Z SITS,TTYHGH==LSTTY +TTYCHK: CMP E,#TTYHGH ;TO BIG? + BLO 1$ ;NO + CMP E,#-1 ;IS IT HIS TTY? + BEQ 1$ ;FINE + ERROR+TDE ;DONT EXIST +1$: RTS PC + +OPEN1: JSR PC,TTYCHK ;TO BIG A NUMBER + BEQ 3$ ;HIS TTY, DO NOTHING + TSTB TTYCPS(E) ;ALREADY OPEN? + BEQ 1$ ;NO + RTS PC +1$: SAVE <#-1,E,#.TTCAP*400> ;TRY TO CREATE IT + .INVOK + BNE 2$ ;GOT IT + ERROR+DIU ;ALREADY IN USE +2$: MOV (P)+,F ;GET THE CAP NUMBER + MOVB F,TTYCPS(E) ;SAY THAT WE HAVE IT + SAVE <,#.TIMGO+.TIMGI,F> ;SET THE STATUS TO IMAGE IN AND OUT + BISB #.TTMOV,1(P) ;DO A MOVE INTO THE STATUS WORD + $INVOK +3$: RTS PC + +CLOSE: POPS E ;GET NUMBER OR SPEC + JSR PC,DEVNUM ;GET THE NUMBER OR DEVICE +CLOSE1: JSR PC,TTYCHK ;CHECK FOR VALID NUMBER + BEQ 1$ ;WAS HIS TTY + MOVB TTYCPS(E),A ;GET THE CAP NUMBER IF OPEN + BEQ 1$ ;NOT OPEN FORGET IT +.IFNZ TVS + JSR PC,TVTCHK + BEQ 2$ + SAVE <#0> + MOVB TTYCPS(E),(P) + MOVB #.VICAM,1(P) + SAVE #<.VIABS*400>+17 + $VIDSW ;SWITHC TO BLANKNESS +.ENDC +2$: CLRB TTYCPS(E) ;CLEAR IT + JSR PC,DELCAP +1$: SEZ + RTS PC + +.IFNZ TVS +TVGRAB: JSR PC,UGTTYG ;OPEN THE TTY + BEQ TVGRB3 ;HIS TTY DOES NOTHING + JSR PC,TVTCHK + BNE TVGRB2 ;YES TV, GO AHEAD AND TRY TO INIT +TVGRB1: JSR PC,CLOSE1 ;GIVE UP ON THIS ONE + ERROR+TDE ;DOESN'T EXIST? (WELLL) +TVGRB2: SAVE <#-1,#140000,#.DSCAP*400+0> ;CREATE A DISPLAY + MOVB TTYCPS(E),2(P) ;FOR THIS TTY CAP + .INVOK ;TRY TO GET A DISPLAY + BEQ TVGRB1 ;TOUGH LUCK BUNKY + MOV (P)+,A ;SAVE CAP TO DISPLAY + CMP (P)+,(P)+ ;EXTRA STUFF NO GOOD FOR TV DISPLAY + TST -(P) + SAVE ;CAP TO DISPLAY AGAIN + MOVB TTYCPS(E),(P) ;TO ATTACH KEYBOARD TO TTY + MOVB #.TVATC,1(P) ;USE DUMMY FROM ABOVE, DS CAP ON STACK AND THIS + $INVOK ;SHOULD NEVER FAIL + JSR PC,DELCP ;NOW WE CAN GET RID OF THE DISPLAY CAP + CMP -(P),-(P) ;DUMMIES + SAVE #0 + MOVB TTYCPS(E),(P) + MOVB #.TVCL,1(P) ;CLEAR SCREEN FUNCTION + $INVOK + CMP -(P),-(P) ;DUMMIES + SAVE #0 + MOVB TTYCPS(E),(P) + MOVB #.TVREV,1(P) ;REVERSE SCREEN + $INVOK + SAVE <,#0,#0> + MOVB TTYCPS(E),(P) + MOVB #.TVFNT,1(P) + $INVOK ;SET FONT 0 + SAVE #0 + MOVB TTYCPS(E),(P) + MOVB #.VICAM,1(P) ;TTY IS DEST + SAVE (P) ;AND SOURCE + $VIDSW ;SWITCH! +TVGRB3: SEZ + RTS PC + +.SETFO: JSR PC,G1NARG ;B GETS FONT NUMBER + SPOPS E ;GET TTY NUMBER + JSR PC,DEVNUM ;GET NUMBER INTO E + SAVE <,B,#.TVFNT*400> + TST E ;IS IT FOR ANOTHER TTY, OR ME + BPL 1$ ;ANOTHER TTY + MOVB #2,(P) ;MY CONSOLE + BR 2$ +1$: MOVB TTYCPS(E),(P) +2$: .INVOK + BNE 3$ + ERROR+WTA +3$: SEZ + RTS PC + +.TVOMODE: + MOV S,A ;REVERSE THE TWO ARGS + EXCH (A),2(A) + JSR PC,UGTTYG ;GET THE TTY + BEQ TVOMOD ;IT IS OUR TTY + MOVB TTYCPS(E),F ;GET THE TTY NUMBER + JSR PC,TVTCHK ;BE SURE IT IS A TTY + BNE TVMOD1 ;IT IS A TV + ERROR+OTVS +TVOMODE: + MOV #2,F ;THIS CONSOLE + JSR PC,TVCNSL ;MAKE SURE IT IS A TV +TVMOD1: JSR PC,G1NARG ;B_ ARGUMENT + INC B ;CHANGE TO REAL NUMBER SYSTEM UNDERSTANDS + BEQ TVMOD2 ;BARF BAD STUFF + CMP B,#.TVMOV ;IS IT LEGAL + BHI TVMOD2 ;BAD ARGUMENT + SAVE <,B,F> ;SAVE ARG AND TTY NUMBER + BIS #.TVMOD*400,(P) ;SET IN THE FUNCTION + $INVOK ;SHOULDN'D FAIL + SEZ + RTS PC +TVMOD2: ERROR+WTIB ;BAD ARGUMENT + +.TVHERE: + JSR PC,UGTTYG ;GET THE TTY NUMBER INTO E + BEQ TVHERE + MOVB TTYCPS(E),F ;GET THE CAPABILITY NUMBER + JSR PC,TVTCHK ;IS IT A TV + BNE TVHER1 ;IT IS A TV + ERROR+OTVS +TVHERE: MOV #2,F ;FOR THE CAPABILITY FOR THE INPUT CAP + JSR PC,TVCNSL ;MAKE SURE WE ARE ON TV +TVHER1: SAVE <,,F> ;READ THE CURSOR POSITION + BIS #.TVSET*400,(P) ;READ IT, + $INVOK + REST ;GET THE LINE, THEN CURSOR + SAVE C ;RESAVE THE LINE NUMBER + JSR PC,PSHNUM ;PUSH CHARACTER NUMBER ONTO THE S PDL + REST B ;GET BACK THE LINE NUMBER + JSR PC,PSHNUM ;PUSH IT + MOV #2,D ;TELL SENTENCE THERE ARE TWO THINGS TO BE HACKED + JMP SENT. ;RETURN IT TO THE USER + +.CURSET: + MOV S,A ;POINT INTO THE S STACK + EXCH (A),2(A) ;EXCHANGE THE TWO ARGUMENTS + JSR PC,UGTTYG ;GET THE TTY NUMBER INTO E + BEQ CURSET ;JUST MY CONSOLE + MOVB TTYCPS(E),F ;GET THE TTY CAPABILITY + JSR PC,TVTCHK ;IS IT A TV + BNE CURST1 ;YES + ERROR+OTVS +CURSET: MOV #2,F ;FOR THE TTY INPUT CAP + JSR PC,TVCNSL ;MAKE SURE IT IS A TV +CURST1: MOV @S,C ;GET POINTER TO THE STRING + MOV #7777,D + BIT D,C ;BETTER NOT BE EMPTY + BNE 3$ ;OKAY +2$: ERROR+WTA ;LOSER +3$: JSR PC,.LOADC ;A,B<= (C) + MOV A,C ;NEXT ELEMENT + MOV #SNUM,A ;CONVERT TO SNUM + JSR PC,CONVERT + BEQ 2$ ;LOST FOR SOME REASON + SPUSH B ;THERE IS THE CHARACTER NUMBER + BIT D,C ;STILL LIST LEFT + BEQ 2$ ;NOPE + JSR PC,.LOADC ;LOAD UP NEXT ELEMENT + BIT D,A ;FINISHED + BNE 2$ ;NO, WHAT A LOSER + MOV #SNUM,A ;CONVERT AGAIN + JSR PC,CONVERT + BEQ 2$ + SPUSH B ;SAVE THE LINE NUMBER + SPUSH F ;AND THE TTY CAPABILITY + BIS #<.TVSET+.TTWRT>*400,(P) ;SET THE CURSOR POSITION + .INVOK ;HOPE THIS WINS + BEQ 1$ ;FAILED (BAD POSITION?) + SEZ ;RETURN TRIUMPHANT + RTS PC +1$: ERROR+OOB ;TO FAR ONE WAY OR THE OTHER + +TVCNSL: SAVE <,,#2> ;MAKE SURE A TV + BIS #.TTTYP*400,(P) ;SET IN THE FUNCTION + $INVOK ;GET THE TYPE OF THE TTY + BIT #200,(P)+ ;CHECK THE TV BIT + BEQ 1$ ;NOT A TV + RTS PC +1$: ERROR+OTVS + +TVTCHK: SAVE <,,#0> + MOVB TTYCPS(E),(P) + BIS #.TTTYP*400,(P) ;GET THE TYPE + $INVOK + BIT #200,(P)+ ;IS IT A TV? + RTS PC +.ENDC + + DEVNUM: PUSH A + SPUSH B + MOV #SNUM,A ;TRY TO CONVER TO NUMBER + MOV E,B ;POINTER TO THE STRING OR NUMBER + JSR PC,CONVERT + BEQ 1$ ;FAILED TRY TO GET A STRING + MOV B,E ;RETURN VALUE IN E +2$: JMP RETB ;RETURN +1$: MOV #LSTR,A ;INTO STRING + JSR PC,CONVERT + BEQ DNUM2 ;FAILED IN BOTH + MOV B,E ;POINTER TO THE NAME +; JSR PC,DEVNAM ;FIND THE DEVICE NAME +; BNE 2$ ;GOT IT +DNUM2: PUSHS E ;PUSH BACK THE INVALID NAME + ERROR+DNA ;BAD NAME + +;DEVNAM: ERROR+SIT + +.IFNZ PTBOX +TBREST: PUSH C + MOV #CONSO,C + JSR PC,TBINIT + POP C + RTS PC +TBINIT: TST PTBF + BNE 1$ ;OWNS ONE + RTS PC +1$: JSR F,ACSAV + MOV #PTBTAB,B +TBINT2: MOV #4,A +TBINT3: CMPB C,(B) + BEQ TBINT4 + TST (B)+ + SOB A,TBINT3 +TBINSZ: REST + SEZ + RTS PC +TBINT4: +; TST F +; BMI TBINT5 + TST (B) + BPL TBINT5 +TBINCZ: REST + CLZ + RTS PC +TBINT5: TST -(P) ;FOR THE SETTING OF THE STATUS BELOW + CMP -(P),-(P) + SPUSH TYOCP + BIS #.TTRD*400,(P) + $INVOK ;READ OLD STATUS + TST -(P) + SPUSH #.TIMGO + SPUSH TYOCP + BIS #.TTBIS*400,(P) ;BIS THE IMAGE OUT BIT + $INVOK +;NOTE HERE ON THE STACK IS THE OLD STATUS, THEN AN EMPTY WORD + MOV #21,D + JSR PC,TYO ;OUTPUT THE ATTENTION CHARACTER TO THE THORTON BOX + MOV B,D + SUB #PTBTAB,D ;GET THE INDEX OF THE THING SELECTED + MOV TBCCHR(D),D ;GET THE SELECT CHARACTER + JSR PC,TYO + BIS #100000,(B) + MOV (B),C + BIC #TBMASK,C + CMP C,#CONSO + BNE TBINT6 + MOV OTTYST,(P) ;CHANGE THE STATUS + BIS #.TIRST,(P) + BR TBINT7 ;DESTROY OLD USER +TBINT6: BIS #.TIMGO,(P) +TBINT7: SAVE TYOCP ;THE CAPABILITY + BIS #.TTMOV*400,(P) ;SET THE TTY STATUS + $INVOK + MOV #PTBTAB,C ;POINT TO THE TABLE AGAIN + MOV #4,D +TBINT8: TST (C) + BGE TBINT9 + CMP C,B + BEQ TBINT9 ;DONT CLEAR THE ONE WE JUST SET + BIC #100000,(C) +TBINT9: TST (C)+ + SOB D,TBINT8 + BR TBINCZ +.ENDC +.ENDC ;END TYI/O LSICOND + +.exami: jsr pc,g1narg + mov (b),b + jmp r1narg + +.DEPOS: JSR PC,G1NARG + MOV B,D + JSR PC,G1NARG + MOV B,(D) + SEZ + RTS PC + .IFNZ SITS + +EXNODE: MOV #NODEHP,A ;POINTER TO BLOCK + JSR PC,EXSPAC ;TRY TO EXPAND NODE SPACE + BEQ EXNOD1 ;FAILED + ADD #2000,NODTOP +EXNOD1: RTS PC ;LOSE OR WIN + +.IFF + +;ROUTINE TO EXTEND NODE SPACE; MUST SLIDE ARRAY SPACE DOWN +;TO MAKE ROOM +;CLOBBERS A,B,C +EXNODE: MOV NODTOP,A ;A_TOP OF NODE SPACE + ADD #2000,A ;EXTEND IT + CMP A,#NODESP+40000 ;MORE THAN 8K WORDS? + BHI 2$ ;SORRY, CAN'T DO THAT (ONLY 12 BITS OF NODE PTRS) + JSR PC,TOPCOM ;COMPUTE TOP + BLOS EXNOD1 ;YUP, GO ON +1$: JSR PC,.PRESS + JSR PC,TOPCOM + BLOS EXNOD1 +2$: SEZ + RTS PC + +TOPCOM: MOV ARTOP,B ;B_ARTOP + ADD #2000,B ;ARRAY SPACE WILL BE SLID UP IF NODESP EXPANDED + CMP B,PPDTOP ;IS THERE ROOM TO SLIDE? + RTS PC + ;NOW, ADVANCE ARRAY SPACE POINTERS +EXNOD1: TST AROVER + BEQ 1$ + ADD #2000,AROVER +1$: MOV AFREE,C ;C_PTR TO NEXT FREE BLOCK + BEQ EXNOD2 ;UNLESS PTR WAS NULL, + ADD #2000,AFREE ; ADVANCE IT +EXNOD2: MOV ARYAD,D ;D_PTR TO BLOCK AFTER CURRENT ARRAY + ADD #2000,ARYAD ;ADVANCE ARYAD (AND NODTOP) +EXNODL: CMP D,ARTOP ;END OF SPACE? + BEQ EXNODD ;YES, DONE WITH POINTERS + BLO 1$ ;NO, CONTINUE + ERROR+BUG +1$: CMP C,D ;IS NEXT BLOCK FREE? + BEQ EXNOD3 + ADD #2000,@(D) ;NO, IT'S AN ARRAY. ADJUST PTR TO IT + ADD 2(D),D ;AND POINT TO NEXT BLOCK + BR EXNODL +EXNOD3: ADD 2(D),D ;POINT TO NEXT BLOCK + MOV (C),E ;POINT TO NEXT FREE BLOCK + BEQ EXNODL ;IF THERE WAS NONE, PROCEED. + ADD #2000,(C) ;ELSE, ADVANCE OLD BLOCK'S FWD PTR + ADD #2000,4(E) ;AND NEW BLK'S BK PTR + MOV E,C ;OLD IS NEW + BR EXNODL + +EXNODD: MOV B,ARTOP ;SHIFTED BOUND + MOV B,A + SUB ARYAD,A + ASR A ;# OF WORDS IN ARRAY SPACE + BEQ EXNOD4 +EXNDL1: MOV -2002(B),-(B) ;SLIDE ARRAY SPACE + SOB A,EXNDL1 +EXNOD4: RTS PC +.ENDC + .IFNZ LSI +;SSYTEM CHECKING CODE + +;ROUTINE TO XOR ALL PURE CODE +XORPUR: MOV #PURES,A + MOV #</2>&77777,B ;COUNT OF PURE WORDS + CLR F ;WHERE THE XOR IS KEPT +1$: MOV (A)+,C ;GET A WORD + XOR C,F ;XOR IT IN + SOB B,1$ + RTS PC + +SETXOR: JSR PC,XORPUR + MOV F,SYSXOR ;SAVE THE XOR OF THE SYSTEM + RTS PC + +CHKXOR: JSR PC,XORPUR + MOV SYSXOR,C + XOR F,C + RTS PC +.IFZ 105 ;MAYBE FASTER WAY TO SET UP TABLE +FASSET: MOV #SYSTAB,A + MOV #16.,B +9$: CLR (A)+ + SOB B,9$ + MOV #PURES,A + MOV #</2>&77777,B + MOV #2,D + MOV #SYSTAB-2,F +1$: MOV (A)+,C + MOV F,E +2$: ADD D,E + ROR C + BEQ 3$ + BCC 2$ + XOR A,(E) + BR 2$ +3$: BCC 4$ + XOR A,(E) +4$: SOB B,1$ + RTS PC +.ENDC + + + + + +;XOR ADDRESS+2 IN FOR EVERY WORD THAT HAS BIT SET +;BIT NUMBER IN D, RETURNS WITH TABLE ADDRESS IN E +BITXOR: MOV #PURES,A + MOV #</2>&77777,B + MOV #1,C + ASH D,C + MOV D,E + ASL E + ADD #SYSTAB,E + CLR F +1$: BIT C,(A)+ ;TEST FOR BIT IN C + BEQ 2$ + XOR A,F +2$: SOB B,1$ + RTS PC + +;SET BIT XOR FOR BIT (D) +SETBIT: JSR PC,BITXOR + MOV F,(E) + RTS PC + +;CHECK BIT XOR FOR BIT (D) +CHKBIT: JSR PC,BITXOR + MOV (E),A + XOR A,F + RTS PC + +;SETUP TABLES FOR FIRST TIME, OR AFTER A PATCH +SETTAB: JSR PC,SETXOR ;DO THE XOR + MOV #15.,D ;START AT THE TOP +1$: JSR PC,SETBIT + DEC D + BGE 1$ + MOV PC,XORFLG ;INDICATE THAT SYSTEM HAS BEEN XORED + SEZ ;IF CALLED BY USER + RTS PC + + ;CHECK THE WORLD +CHKTAB: JSR PC,CHKXOR + BEQ XRTSPC + SAVE #0 ;ADDRESS+2 OF CHANGED WORD + SAVE C ;THESE ARE THE BITS THAT CHANGED IN THE WORD + MOV #15.,D +CHKTA1: JSR PC,CHKBIT ;CHECK THIS BIT + BEQ CHKTA2 ;THIS BIT SHOULD BE RIGHT + BIT C,(P) ;THIS BIT SHOULD BE WRONG + BEQ MULERR ;MULTIPLE ERROR +CHKTA4: TST 2(P) ;HAVE WE ALREADY GOT AN ADDRESS? + BNE CHKTA3 ;YUP + MOV F,2(P) ;THIS IS THE ERROR ADDRESS +CHKTA3: CMP F,2(P) ;SAME ERROR ADDRESS? + BNE MULERR ;NOPE, MULTIPLE WORD ERROR +CHKTA5: DEC D + BGE CHKTA1 + REST ;A GETS WRONG BITS, B GETS ADDRESS+2 + XOR A,-(B) ;FIX THE ERROR + MOV A,WRNGBT ;SAVE FOR LATER + MOV B,WRNGAD + SAVE PCHR + MOV #LSISTY,PCHR ;SPECIAL "SUPER" TYO + PRTXT < +MEM ERR CORRECTED @> + MOV WRNGAD,A + JSR PC,PRONL + PRTXT < BITS:> + MOV WRNGBT,A + JSR PC,PRONL + JSR PC,.CRLF + REST PCHR + INC WRNGCN ;ONE MORE CORRECTED + RTS PC + +CHKTA2: BIT C,(P) + BNE MULERR ;THIS BIT SHOULD BE RIGHT, IS WRONG + BR CHKTA5 + +MULERR: SAVE PCHR + MOV #LSISTY,PCHR ;SPECIAL SUPER TYO + PRTXT < +WARNING, MULTIPLE MEMORY ERROR DETECTED, IGNORING +> + REST PCHR + MOV PC,IGNERR + CMP (P)+,(P)+ +XRTSPC: RTS PC + +SYSCHK: TST IGNERR ;TOO MANY ERRORS? + BNE SYSCH1 + JSR F,ACSAV + TST XORFLG ;HAS SYS BEEN XORED? + BNE 1$ + JSR PC,SETTAB ;XOR THE SYSTEM +1$: JSR PC,CHKTAB ;CHECK THE SYSTEM + JSR F,ACRES +SYSCH1: SEZ + RTS PC + +;INCREMENTAL CHECK +INCHK: TST IGNERR ;IGNOREING ERRORS? + BNE INCHK3 ;THEN DON'T LOOK FOR ANY + JSR F,ACSAV + MOV INCNT,B ;GET OLD LEFTOVER COUNT + BEQ INCHK1 ;FINISHED LAST CHECK, RESTART + MOV INADDR,A ;OLD ADDRESS + MOV INXOR,F ;OLD XOR + SUB #500.,B + BLT 1$ + MOV B,INCNT + MOV #500.,B + BR 2$ +1$: ADD #500.,B ;THE REAL COUNT LEFT OVER + CLR INCNT ;FLAG THAT WE WILL BE FINISHED THIS CHECK +2$: MOV (A)+,C ;GET A WORD + XOR C,F ;PUT INTO CHECKSUM + SOB B,2$ + TST INCNT ;DONE? + BNE INCHK2 ;NOPE, SAVE FOR NEXT TIME + TST F ;SHOULD BE ZERO + BEQ INCHK1 ;YUP, WIN + JSR PC,SYSCHK ;CHECK FOR REAL +INCHK1: MOV #PURES,A + MOV #</2>&77777,INCNT + MOV SYSXOR,F +INCHK2: MOV A,INADDR + MOV F,INXOR + JSR F,ACRES +INCHK3: RTS PC + +.ENDC + .SBTTL SYSTEM OBLIST SORT +DC PUREE,. +;KLUDEGY SELF MODIFIYING CODE +.IFNZ LSI&TIMCLK +GETTIM: MOV #207,GETTIM + JMP RGETTI +.ENDC +.IFNZ LSI +SORT: MOV #207,SORT ;CLOBBER YOURSELF + JMP RSORT +STORAG=. ;THE REST OF THE ROUTINE IS USED FOR FREE STORAGE +DC ERTXT,. +.=.+ERTXTL ;LEAVE ROOM FOR THE ERROR TEXT +.ENDC +.IIF Z LSI,SORT: +RSORT: MOV #SOBLST+2,A ;POINTER TO START AT + MOV #SOBLSU,B ;PLACE TO FINISH + MOV PC,F ;SET "SOMETHING MOVED" FLAG +SORTUG: TST F ;DID SOMETHING GET MOVED LAST PASS? + BEQ SORTDN ;NO, WE ARE DONE + CLR F ;NOTHING SO FAR THIS PASS + MOV A,C ;POINTER INTO TABLE +SORTU: MOV (C)+,D ;START OF SORT UP + MOV (C),E ;THINGS TO SORT + ADD #4+SOBLST,D ;GET TO STRING + ADD #4+SOBLST,E ;FOR BOTH +SORTU3: CMPB (D),(E) ;COMPARE THE WORDS + BLT SORTU2 ;IN ORDER, GO TO NEXT PAIR + BEQ SORTU1 ;SAME, CHECK NEXT WORD + INC F ;HAVE TO SWITHC THEM + MOV -(C),D + MOV 2(C),(C)+ + MOV D,(C) +SORTU2: CMP C,B ;ARE WE AT END? + BNE SORTU ;NO, CONTINUE + TST -(B) ;YES, NEXT TIME NOT SO FAR + BR SORTDG ;GO TO DOWNWARD SORT +SORTU1: TSTB (D)+ + BNE 1$ ;NO, OK + MOV #ZERO,D ;YES, KEEP IT THAT WAY +1$: TSTB (E)+ + BNE 2$ + MOV #ZERO,E +2$: CMP D,E ;ARE THEY THE SAME (I.E. ZERO?) + BNE SORTU3 ;OK, CONTINUE + BPT ;BARF, THEY'RE EQUAL???? + BR SORTU3 + +SORTDG: TST F ;DID WE MOVE ANY ON THE UP PASS? + BEQ SORTDN ;NO,DONE + CLR F ;CLEAR FLAG + MOV B,C ;SET POINTER +SORTD: MOV (C),D + MOV -(C),E + ADD #4+SOBLST,D + ADD #4+SOBLST,E +SORTD3: CMPB (D),(E) + BGT SORTD2 + BEQ SORTD1 + INC F + MOV (C)+,D + MOV (C),-(C) + MOV D,2(C) +SORTD2: CMP C,A + BNE SORTD + TST (A)+ + BR SORTUG +SORTD1: TSTB (D)+ + BNE 1$ ;NO, OK + MOV #ZERO,D ;YES, KEEP IT THAT WAY +1$: TSTB (E)+ + BNE 2$ + MOV #ZERO,E +2$: CMP D,E ;ARE THEY THE SAME (I.E. ZERO?) + BNE SORTD3 + BPT + BR SORTD3 + +SORTDN: RTS PC + +.IFNZ LSI&TIMCLK +TCUDAT=174770 +TCUTIM=TCUDAT+2 +TCUSEC=TCUTIM+2 + +RGETTI: + SAVE 4 + MOV #1$,4 ;IF THERE IS NO CLOCK + MOVB TCUDAT+1,B ;GET THE MONTH + REST 4 + MOV #LSYEAR,A ;POINTER TO THE YEAR + MOV #79.,(A) ;PROBABLY 79 + CMPB #11.,B ;UNLESS IT'S NOV OR DEC + BGT 2$ ;NOPE + DEC (A) ;STILL IN 78 +2$: MOV B,-(A) ;STUFF THE MONTH + MOVB TCUDAT,B ;GET THE DAY + MOV B,-(A) + MOVB TCUTIM+1,B ;THE HOUR + MOV B,-(A) + MOVB TCUTIM,B + MOV B,-(A) + MOV TCUSEC,-(A) + RTS PC + +1$: CMP (P)+,(P)+ + REST 4 +STLANC +ENGINS < CPRTXT ^\Date and time YY/MM/DD HH:MM:SS :\> +ENDENG +FRINS < CPRTXT ^\Date et heure AA/MM/JJ HH:MM:SS :\> +ENDLAN + MOV #LSYEAR+2,C +GETNM1: CLR B + CLR F +GETNUM: JSR PC,ONETYI + CMP #177,D + BEQ RGETTI + CMP #15,D + BEQ NOTIM1 + JSR PC,TYO + SUB #60,D + BLT GOTNUM + CMP #10.,D + BLE GOTNUM + INC F + MUL #10.,B + ADD D,B + BR GETNUM +GOTNUM: CMP #LSSEC,C + BEQ NOTIME + TST F + BEQ GETNM1 +1$: MOV B,-(C) + BR GETNM1 +NOTIM1: TST F + BEQ NOTIME + MOV B,-(C) +NOTIME: RTS PC +.ENDC + +.IIF NZ NOISPACE,STORAG: +DC CODEND,. +.IIF DF PASS2,PAD ^\CODEND=\,\. +LOGEND=. +.IIF NZ LSI,.IIF DF PASS2,PAD ^\STORAG=\,\STORAG +DC PASS2,0 + + .END START + + \ No newline at end of file diff --git a/src/nlogo/displa.31 b/src/nlogo/displa.31 new file mode 100755 index 00000000..19b6ad84 --- /dev/null +++ b/src/nlogo/displa.31 @@ -0,0 +1,5301 @@ + .SBTTL TURTLE,DISPLAY, RANDOM DEVICES, AND OTHER CRAP + +.MACRO GTJUMP ADDR +.IFNZ GTL + TST GTLDF + BEQ .+6 + JMP ADDR +.ENDC +.ENDM + +;CONVERT ADDRESS TO DISPLAY PUSHJ +;ARGUMENT IS AC +.MACRO MAKEPJ F + ASR F + ADD DRELOC,F + BIS #DPUSHJ,F +.ENDM + +;CONVERT DISPLAY CONTROLLER ADDRESSES TO REAL WORLD ADDRESSES +; ARG IS AC +.MACRO MAKEAD F + SUB DRELOC,F + ASL F +.ENDM + .IFZ LSI ;LSICOND, EXTENDS TILL MUSIC PRIMITIVES + +MUWAIT: + ERROR+SIT + .SBTTL RANDOM DEVICE CONTROL + +.IFNZ AI + +ATOD: ERROR+SIT +.IFZ 105 + JSR PC,G1NARG + TST B ;IS B NEGATIVE + BLT ATODLS ;YES, SO NO GOOD + CMP #7,B ;IS B TOO BIG A CHANNEL NO.? + BLT ATODLS ;YES ITS BIGGER THEN 7 + ASH #10.,B + MOV B,ATODB + TST ATODB + BPL .-4 + MOV ATODB,B + BIC #176000,B + SUB #1000,B + JMP R1NARG +ATODLS: ERROR+WTA ;HERE FOR BAD ARG TO ATOD +.ENDC + + +BITOUT: ERROR+SIT +.IFZ 105 + JSR PC,G1NARG + MOV B,DIGO +BITOU1: SEZ + RTS PC +.ENDC +RELAY: ERROR+SIT +.IFZ 105 + JSR PC,G1NARG + MOV B,F + JSR PC,G1NARG + MOV #1,C + ASH B,C + TST F + BEQ RELAY1 + BIS C,DIGO + BR BITOU1 +RELAY1: BIC C,DIGO + BR BITOUT + +.ENDC +DEVICE==160106 ;THE ADDRESS OF THE BUFFER REGISTER +DEVADD==160104 ;THE SELECTOR REGISTER + +BOXIN: JSR PC,G1NARG + JSR PC,RDBOX ;READ THE BOX + JMP R1NARG + +SWITCH: JSR PC,G2NARG + CMP A,#15 + BGT SWTWTA + TST A + BLT SWTWTA + JSR PC,RDBOX ;BOX NUMBER IN B, RETURNS THE BOX IN B + MOV #1,C ;GET THE BIT + ASH A,C ;SHIFT THE BIT THE NUMBER OF THE SWITCH + BIT C,B ;IS THE BIT SET + BNE 1$ ;YES + JMP RTFALS ;RETURN FALS +1$: JMP RTTRUE ;RETURN TRUE + +RDBOX: ERROR+SIT +SWTWTA: ERROR+SIT +.IFZ 105 + TST B ;IS IT NEGATIVE + BGE .+4 +SWTWTA: ERROR+WTA ;BAD ARG + CMP B,#3 ;TO LARGE BOX NO. + BGT SWTWTA + ASH #10.,B ;THE NUMBER IS SHIFTED 10 PLACES + MOV B,DEVADD ;TELL IT WHICH BOX TO READ + CLR DEVICE ;TELL IT TO GO + TST DEVICE ;DATA IN YET + BPL .-4 ;NOT YET + MOV DEVICE,B ;GET THE DATA INTO B + COM B ;THE BITS ARE COMPLEMENTED + RTS PC +.ENDC +.ENDC +;ROUTINE FOR THE EYETURTLE. WE WANT TO FILL A LOGO ARRAY WITH WHAT APPEARS +;A-TO-D CHANNEL, SAMPLING THAT A-TO-D 720 TIMES IN ONE ROTATION OF THE TURTLES'S +;EYE. THE TURTLE SENDS US A PULSE WHENEVER IT SHOULD BE SAMPLED +EYE: ERROR+SIT +.IFZ 105 + SPUSH #1 ;TELL AMAKE THERE IS ONLY ONE ARG + SPUSH PS ;SAVE PSW AND PRIORITY + MOV @S,A ;S POINTS TO ARRAY NAME + JSR PC,AMAKE ;FIND TOP OF THE ARRAY + ADD #2,S ;POP STACK + CMPB 5(B),#260 ;TEST TYPE BYTE + BEQ 1$ ;BRANCH IF IT'S AN INTEGER ARRAY + ERROR+BAT ;BAD ARRAY TYPE +1$: CMP 10.(B),#720.;IS THE FIRST DIMENSION 720. LONG? + BGE 2$ ;AT LEAST THAT BIG + ERROR+BAT ;TOO SMALL,TOO BAD + CRDPOS==5 ;USE INTERFACE LINE FIVE +;THE A-TO-D DEVICE BUFFER REFERRED TO ABOVE IS ALSO THE SWITCHBOX ADDRESS +;REGISTER. I DON'T KNOW WHY. +2$: ADD #12.,B ;B NOW POINTS TO FIRST ENTRY OF ARRAY + MOV #CRDPOS,D + ASH #10.,D ;THIS MAKES THE LINE-SELECTION ACCEPTABLE TO ADDRESS BUFFER + MOV D,ATODB ;AND WE HAVE NOW SELECTED INTERFACE LINE FIVE. + MOV #720.,C ;WE WANT 720. POINTS + SPL 7 ;LOCK OUT ALL INTERRUPTS +GNDATA: CLR DEVICE ;TAP THE EYETURTLE ON THE SHOLDER,GET READY FOR A PULSE + TST DEVICE ;DID WE GET A TIMING PULSE BACK YET? + BPL .-4 ;WAIT FOR THAT PULSE + TST ATODB ;IS CONVERSION COMPLETE? + BPL .-4 ;NO, WAIT + TST (B)+ ;ARRAYS ARE DOUBLEWORD LONG, SO INCR PNTR + MOV ATODB,(B)+ ;YES PUT IN THE ARRAY AND INCREMENT POINTER + SOB C,GNDATA ;IF NOT YET 720 POINTS GO GET ANOTHER + SPOP PS ;RESTORE THE OLD PRIORITY + SPOP A ;CLEAN THE P-PDL UP + SEZ ;TELL EVAL THAT NOTHING IS BEING RETURNED + RTS PC +.ENDC + .IIF NZ HALFLG, .INSRT HALHACK > + + +.SBTTL DISPLAY AND TURTLE + +;A BRIEF DESCRIPTION OF WHAT IS LEFT TO BE DONE TO THIS PROGRAM. + + +;4) DECIDING WHAT SNAP AND WIPE REALLY ARE GOING TO DO. +;AT THIS TIME, SNAP OUTPUTS THE ENTIRE SCREEN +;AND WIPE ERASES ONLY TOP LEVEL OCCURRENCES OF THE SNAP + + + +.ENDC +.IFNZ NPLOT!NDISP!TURFLG +;DISPLAY AND TURTLE COMMANDS + .IFZ + DLT==0 + DRT==1 + DFD==2 + DBK==3 + DPD==4 + DPU==5 + .ENDC + + CURY==4 ;USED FOR INDEXING OFF CURX FOR + CURA==10 ;PLOTTER AND DISPLAY + COSA==14 + SINA==20 + RCURX==24 + +BACK: GTJUMP GTBACK + MOV #"@C,D ;D _ CHAR. TO SEND TO TURTLE + MOV #DBK,E ;IN ORDER TO CAUSE 1 STEP OF MOTION + BR TURD ;THE TOP BYTE CONTAINS THE CHAR. +LEFT: GTJUMP GTLEFT + MOV #"BA,D ;IF THE NUMBER OF STEPS IS NEGATIVE + MOV #DLT,E + BR TURD +RIGHT: GTJUMP GTRIGH + MOV #"AB,D ;E CONTAINS THE ADDRESS OF THE PARALLEL + MOV #DRT,E ;DISPLAY ROUTINE + BR TURD +FORWARD: GTJUMP GTFORW + MOV #"C@,D + MOV #DFD,E +;THE MOVE COMMANDS ARE PROCESSED HERE + +TURD: +.IFZ FPPF + JSR PC,G1NARG ;B_SINGLE PRECISION NUMBER +.IFF + JSR PC,G1NUM ;FA_FLOATING NUMBER + BNE 1$ + ERROR+WTAB +1$: +.ENDC + .IFNZ NDISP + BIT #DISPF,DFLAGS ;DISPLAY, OR REAL TURTLE? + BEQ TURD.1 + JMP (E) ;DISPLAY + .ENDC +TURD.1: BIT #TURTF,DFLAGS + BNE TURD.A ;TURTLE + .IFNZ NPLOT + BIT #PLOTF,DFLAGS + BEQ TURD.E + JMP (E) ;HANDLE PLOTTER COMMAND LIKE DISPLAY + .ENDC +TURD.E: ERROR+VTD ;ONLY VALID FOR TURTLE,DSPLY,OR PLTR +TURD.A: +.IFNZ FPPF + SETI ;IF IT'S A TURTLE CHANGE FLOATING + STCFI FA,B ;TO AN INTEGER + SETL +.ENDC + TST B + BGE TURD.2 + NEG B ;MAKE NUMBER POSITIVE + SWAB D ;AND SWITCH CHARS +;NOW DO THE MOVING +TURD.2: CMP E,#DLT ;FOR LEFT OR RIGHT USE FUDGE FACTOR + BEQ TURD.0 + CMP E,#DRT + BEQ TURD.0 + BR TURD.3 + TURD.0: ASL B + MOV B,A + MOVB TURF,E ;MULTIPLY BY FIRST BYTE + MUL E,A + MOVB TURF+1,E ;DIVIDE BY SECOND + DIV E,A +TUTE: BVS TUTER ;OVERFLOW--LOSE. + MOV A,B + ASR B + ADC B ;DIVIDE BY TWO, ROUNDING. +TURD.3: MOV TURDN,E ;TURTLE DEVICE NUMBER (FOR TYO ROUTINES) + SUB #6.,B + BLT TURD.5 ;NEVER EVEN MAKE IT TO FULL ACCELERATE MODE + MOV #10,C + CLR A ;AGAIN, DIVIDE BY 4 (8) + DIV #4,A + MOV B,F + ;REM.=NUMBER OF STEPS NEEDED BESIDES ACCELERATION +; AND DECELERATION WHICH CAN'T BE TAKEN IN 8'S + INC F ;F_TOTAL NUMBER OF 1 STEPS + JSR PC,TUROUT + ADD C,D ;D_CHAR FOR 2 STEPS + JSR PC,TURTYO + MOV A,F ;F _ NUMBER OF 8 STEPS + INC F + ADD C,D ;D_CHAR FOR 8 STEPS + JSR PC,TUROUT + SUB C,D ;D_CHAR FOR 2 STEPS + JSR PC,TURTYO + SUB C,D ;D_CHAR FOR 1 STEP + JSR PC,TURTYO +.IIF NZ PTBOX, JSR PC, TBREST + SEZ +TURD.4: RTS PC + +;FOR FEWER THAN 14 STEPS, JUST SEND OUT 1 STEPS +;(IN THE WORS CASE, THIS STUPID ALGORITHM REQUIRES TWICE AS +;MANY CHARS AS THE OPTIMAL ALGORITHM) +TURD.5: ADD #6.,B ;RESTORE WHAT WAS SUBTRACTED + MOV B,F + INC F + JSR PC,TUROUT + BR TURB.2 +TUTER: ERROR+TGDZ ;TURTLE GETTING DIZZY +.ENDC + +.IFNZ TURFLG +;MORE TURTLE COMMANDS + +LAMPON: GTJUMP GTLON + MOV #'!,D + BR TURB +LAMPOF: GTJUMP GTLOFF + MOV #'",D + +TURB: JSR PC,TURTST +TURB.1: MOV TURDN,E + JSR PC,TURTYO +TURB.2: .IIF NZ PTBOX, JSR PC,TBREST + SEZ + RTS PC +.ENDC +.IFNZ TURFLG!NDISP!TVS +PENDOWN: GTJUMP GTPD + MOV #'0,D + MOV #DPD,E + BR TURC +PENUP: GTJUMP GTPU + MOV #'8,D + MOV #DPU,E + +TURC: + .IFNZ NDISP + BIT #DISPF,DFLAGS ;TURTLE, OR DISPLAY? + BEQ TURC.1 + JMP (E) + .ENDC +TURC.1: +.IFNZ TURFLG + BIT #TURTF,DFLAGS + BNE TURB.1 +.ENDC + .IFNZ NPLOT + BIT #PLOTF,DFLAGS ;USING PLOTTER + BEQ TURC.2 + JMP (E) + .ENDC + +TURC.2: ERROR+VTD ;ONLY VALID FOR TURTLE,DISPLAY,OR PLOTTER +.ENDC +.IFNZ TURFLG +TURTS1: MOV TURDN,E +TURTST: BIT #TURTF,DFLAGS + BEQ 1$ + RTS PC +1$: ERROR+VTU +.ENDC + +.IFNZ TURFLG +TOOT: JSR PC,G1NARG + JSR PC,TURTS1 + MOV #"( ,D ;TOOT CHAR IN BOTTOM, NULL IN TOP + MOV B,A +TOOT.1: DEC A ;HOW MANY TIMES TO TOOT + BLT TURB.2 + JSR PC,TURTYO ;SHIP OUT TOOT CHAR + MOV #15.,F ;THEN FOLLOW IT WITH 3 NULLS + SWAB D + JSR PC,TUROUT + SWAB D ;RETURN TOOT CHAR TO BOTTOM + BR TOOT.1 + +;TURTLE OUTPUT +;CALL WITH CHAR IN D, NUMBER OF TIMES IN F +TURO9: JSR PC,TURTYO +TUROUT: TST BRAKE + BNE TURDOR + SOB F,TURO9 +TURDOR: RTS PC + +.IFZ BOTUR +TURTYO: SPUSH C + MOV #TURT,C + BIS TURDN,C + JSR PC,TBTYO + SPOP C + RTS PC +.IFF +BOTTKS==177760 +BOTTKB==BOTTKS+2 +BOTTPS==BOTTKB+2 +BOTTPB==BOTTPS+2 +TURTYO: JSR F,ACSAV + MOV TURDN,C ;TURTLE DEVICE NUMBER + MOV #21,A + JSR PC,BOTTYO ;RESET TBOX + CLR B +1$: MOV #40,A + CMP C,B + BNE 2$ + MOV D,A + INC B ;TO OUTPUT ONLY 4 CHARS TOTAL IF TURTLE IS DEV 0, 1 OR 2 +2$: JSR PC,BOTTYO + INC B + CMP #4,B ;DONE? + BGT 1$ + JSR F,ACRES + RTS PC + +BOTTYO: TSTB BOTTPS + BPL BOTTYO + MOVB A,BOTTPB + RTS PC + +TBTW: JSR PC,TURTYO +2$: TSTB BOTTKS + BLT 1$ + BRAKET ;TEST FOR BREAK TYPED + BR 2$ +1$: MOVB BOTTKB,D + RTS PC +.IFT +TBTW: MOV TURDN,E + CLR -(P) + MOVB TTYCPS(E),(P) + $BYTI + REST D + RTS PC +.ENDC + + +TOUCH: PUSH A + JSR PC,TURTS1 + MOV #'#,D + JSR PC,TURTYO + TST PTBF + BNE TOUCH2 + JSR PC,TBTW +TOUCH3: +.IIF NZ PTBOX, JSR PC,TBREST + POP A + BIT A,D + BEQ TOUCH1 + JMP RTFALS +TOUCH1: JMP RTTRUE +TOUCH2: JSR PC,ONETYI + BR TOUCH3 + +FTOUCH: MOV #20,A + BR TOUCH +BTOUCH: MOV #4,A + BR TOUCH +LTOUCH: MOV #10,A + BR TOUCH +RTOUCH: MOV #40,A + BR TOUCH +LFTOUC: MOV #30,A + BR TOUCH +RFTOUC: MOV #60,A + BR TOUCH +LBTOUC: MOV #14,A + BR TOUCH +RBTOUC: MOV #44,A + BR TOUCH +.IFZ 1 +;LIGHT--RETURN INTENSITY SEEN BY TURTLE EYE +LIGHT: + .IFNZ NPLOT + BIT #PLOTF,DFLAGS + BEQ LIGHT1 + MOV PLTCHR,B + BIC #177774,B ;ONLY 2 SIGNIFICANT BITS + JMP R1NARG + .ENDC +LIGHT1: JSR PC,TURTS1 ;CHECK TO SEE IF HE HAS A TURTLE + MOV #'#,D + TST PTBF + BNE LIGHT2 + JSR PC,TBTW +LIGHT3: MOV D,B + BIC #177700,B ;ONLY 6 SIGNIFICANT BITS + JMP R1NARG +LIGHT2: JSR PC,TURTYO + JSR PC,CTYI + JSR PC,SETTTY + BR LIGHT3 +.ENDC +.ENDC + +.IF NZ BOTUR&TURFLG&LSI +STARTT: JSR PC,G1NARG + TST B + BGE 2$ +1$: ERROR+WTA +2$: CMP #3,B + BLT 1$ + CLR GTLDF ;NO MORE GTL DISPLAY + MOV B,TURDN + MOV STURF,TURF + BIC #DISPF!PLOTF,DFLAGS + BIS #TURTF,DFLAGS + SEZ + RTS PC + +KILLTU: BIC #TURTF,DFLAGS + SEZ + RTS PC + + +.ENDC + ;START TURTLE +.IFZ LSI + +ASSTUR: CLR A ;SET FLAG FOR NOT KILLING OTHER DEVICES + COM A + BR .+4 + +STARTT: JMP USETUR +.if z 105 + CLR A ;SET FLAG FOR KILLING OTHER DEVICES + JSR PC,G1NARG ;WHICH TURTLE + TST B + BGT .+4 +STRTT1: ERROR+ITN ;INVALID TURTLE NUMBER + DEC B +; CMP B,#NTUR-1 + BGT STRTT1 +STRTT2: TST PTBF + BEQ STRTT3 + MOV #TURT,A ;TYPE OF TURTLE + ADD B,A ;WHICH TURTLE + JSR PC,TBCHK ;CHECK TO SEE IF HE HAS IT + BNE 1$ + ERROR+VTU +1$: MOV B,TURDN ;TURTLE NUMBERR + MOV STURF,TURF ;USE TURTLE 1'S FUDGE FACTORS + TST A + BLT STRTT4 + PUSH B + JSR PC,KILLT1 ;KILL ANOTHER TURTLE +.IIF NZ NPLOT, JSR PC,KILLPL ;KILL ANOTHER PLOTTER + POP B + BR STRTT4 +STRTT3: ASL B ;TURN INTO WORD INDEX + + PUSH B + TST A ;KILL OTHER DEVICS? + BLT ASTRT1 ;NO +.IIF NZ NDISP, JSR PC,KILLD1 +.IIF NZ NPLOT, JSR PC,KILLPL + JSR PC,KILLT1 +ASTRT1: SPOP B + + MOV TURN(B),E + JSR PC,OPEN1 ;TRY TO OPEN IT + MOV E,TURDN ;USER VARIABLE + MOV STURF(B),TURF ;TURTLE FUDGE FACTOR +STRTT4: BIC #,DFLAGS + BIS #TURTF,DFLAGS ;SET FLAG FOR CONTROL OF TURTLE + BIS #TURTF,DIVOWN ;SET FLAG FOR OWNING TURTLE + SEZ + RTS PC +.endc + +KILLTURTLE: +KILLT1: + + BIT #TURTF,DIVOWN + BEQ KILLT9 ;DOESN'T HAVE A TURTLE + TST PTBF + BNE KILLT3 + MOV TURDN,E + JSR PC,CLOSE1 +KILLT3: BIC #TURTF,DFLAGS + BIC #TURTF,DIVOWN +KILLT9: SEZ + RTS PC + +NODEV: + .IFNZ NDISP + JSR PC,KILLD1 + .ENDC + JSR PC,NOMUSIC + .IFNZ NPLOT +.IIF NZ NPLOT, JSR PC,KILLPL ;KILL ANOTHER PLOTTER + .ENDC +; JSR PC,SLAM ;RELEASE ALL DEVICES FOR THIS USER + TST PTBF + BNE KILLT3 + RTS PC + + .IFNZ NPLOT +;STARTPLOTTER + +ASSTPL: CLR C ;SET FLAG FOR NOT KILLING OTHER DEVICES + COM C + BR .+4 +STRTPL: GTJUMP USEPLO + CLR C ;SET FLAG FOR KILLING OTHER DEVICES + TST PTBF ;THORTON BOX PRIVATE? + BEQ STRTP2 ;NO, JUST IGNORE + MOV #PLOTT,A ;PLOTTER + JSR PC,TBCHK ;CHECK IT OUT + BNE STRTP3 ;HE'S GOT IT + ERROR+DIU ;DONT HAVE ONE, SEND TO THE FACTORY +STRTP2: MOV PLTDVN,E + JSR PC,OPEN1 + +STRTP3: TST C ;SHOULD WE KILL OTHER DEVICES? + BLT STRTP1 ;NOPE + + JSR PC,KILLT1 ;KILL TURTLE IF HE HAS ONE + BIT #DISPF,DFLAGS + BEQ STRTP1 +.IIF NZ NDISP, JSR PC,KILLD2 ;KILL DISPLAY IF HE HAS ONE +STRTP1: MOV #PORBEG,F ;SETT [0 0 0] + BIS #PLOTF,DFLAGS ;SET PLOTTER FLAG + + BIC #,DFLAGS + BIS #PLOTF,DIVOWN ;SET FLAG FOR OWNING PLOTTER + +ZVAR: CLR (F)+ ;CLEAR USER'S PLOTTER VARIABLES + CMP #POREND,F + BNE ZVAR + BIS #PENUF,PLPENP ;SET PENUP FLAG IN PLOTTER + BIS #PENUF,DFLAGS ;START WITH PEN UP + JSR PC,ANGCRP ;INIT SINE AND COSINE + CLR B + CLR C + JSR PC,MTO.02 ;MOVE PLOTTER THERE +ZVAR1: SEZ + RTS PC +;KILLPLOTTER +KILLPL: + TST PTBF ;PRIVATE TBOX? + BNE 1$ ;CLEAR FLAGS + MOV PLTDVN,E + JSR PC,CLOSE1 +1$: + BIC #PLOTF,DIVOWN + BIC #PLOTF,DFLAGS ;ELIM. PLOTTER FLAG + BR ZVAR1 + .ENDC + ;HERE IS WHERE THE DISPLAY PRIMITIVES START. +.IFNZ NDISP + +;STARTDISPLAY +; INITIALIZE EVERYTHING +; ALLOCATE DISPLAY BUFFERS + +ASTRDI: CLR A ;SET FLAG FOR NOT KILLING OTHER DEVICES + COM A + BR .+4 +STARTDISPLAY: CLR A ;SET FLAG FOR KILLING OTHER DEVICES + + +;USE THIS PRIMITIVE TO SPECIFY A LARGE DISPLAY + JSR PC,G1NARG ;B _ #. SHOULD BE 0 OR 1 + + +STRTD0: SPUSH B ;THE KILLERS CLOBBER B + + TST A ;KILL OTHER DEVICES? + BLT ASTRD1 ;NO + + JSR PC,KILLT1 ;GET RID OF TURTLE IF NECSSARY +.IIF NZ NPLOT, JSR PC,KILLPL ;KILL ANOTHER PLOTTER + +ASTRD1: BIT #DISPF,DIVOWN ;DOES HE ALREADY OWN ONE? + BEQ ASD1 ;YES + BIS #DISPF,DFLAGS ;SET FLAG FOR CONTROLING DISPLAY +ASD1: + + + BIT #DISPF,DFLAGS ;DOES HE HAVE A DISPLAY? + BEQ STRTD1 ;USER DOESN'T HAVE A DISPLAY YET + JSR PC,KILLD2 ;KILL HIS PREVIOUS DISPLAY FIRST +;FALLS THROUGH + ;FALLS IN +STRTD1: +;IS THIS USER A DISPLAY USER? +;I.E. IS THERE AN ACTUAL DISPLAY CONSOLE +; ASSOCIATED WITH HIM? +;NOW WE MUST ALLOCATE HIM A DISPLAY BUFFER +;FIRST DETERMINE WHAT SIZE BUFFER HE IS LOOKING FOR. + SPOP B +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV DISPLAY? + BEQ 1$ ;NO, START UP TK DISPLAY + JMP TVSTRT ;YES, START UP TVS +1$: +.ENDC + SAVE <#-1,TYICP> + MOVB B,1(P) + BIS #100000,(P) ;SAY GET THE DISPLAY FOR THIS TTY + SAVE #.DSCAP*400+0 ;ZERO IS MY CREATE CAPABILITY + .INVOK + BNE 2$ + ERROR+NDV +2$: REST + SUB #&77777,A + MOV A,DRELOC + CLR -(P) ;START AND LENGTH DON'T MATER + CLR -(P) ;NEIRTHER DOES PAGE IN SOURCE + SAVE DISCAP ;SOURCE + MOVB #10+DISPG,1(P) ;PAGE IN ME + SAVE <#.CRWRT+1> ;MY SPHERE CAP AND GIVE ME WRITE ACCESS + $MAP + MOV #DORBEG,F ;ZERO VARIOUS USER DISPLAY VARS + MOV #DOREND,D ;LAST WORD +SDLOOP: CLR (F)+ ;ZERO WORD + CMP F,D + BLE SDLOOP + + BIC #,DFLAGS ;CLEAR VARIOUS FLAGS + CLR DPENP ;START WITH THE PENDOWN + BIS #DISPF,DIVOWN ;SET FLAG FOR OWNING DISPLAY + + BIS #DISPF,DFLAGS ;SET FLAG FOR CONTROLLING DISPLAY +;SET UP TURTLE VARIABLES + MOV #TLIST,D + MOV D,TUB + MAKEPJ D + MOV D,PUSHJT +;SET FIRST 2 WORDS OF DLIST +;AND SET THE BUFFER VARIABLES + MOV #DLIST,D + MOV #,(D)+ + MOV PUSHJT,(D) + MOV D,STB ;STATIC AREA BOTTOM + MOV D,STT ;STATIC AREA TOP + ASL B ;B _ LENGTH OF DISPLAY IN BYTES. + ;USE THIS TO CALCULATE WHERE DYNAMIC AREA ENDS + ADD #DISAD,B + CLR -(B) ;SET UP DUMMY FREE AREA + MOV B,DYT ;DYNAMIC AREA TOP + CLR -(B) + MOV B,DYB ;DYNAMIC AREA BOTTOM + MOV B,DYR ;DYNAMIC AREA ROVING POINTER +;DRAW THE TURTLE + PUSH C + JSR PC,ANGCRP ;CALCULATE ANGLE CRAP + JSR PC,DR.TUR ;DRAW TURTLE + SPOP C +;NOW MAKE A PUSHJ TO THE DISPLAY LIST +;AND STUFF IT INTO THE HARDWARE FIRST LOCATION FOR THIS DISPLAY + TST -(P) + SAVE #&77777 + ADD DRELOC,(P) + SAVE DISCAP + $INVOK ;START UP THE DISPLAY +;AND LAST BUT NOT LEAST + JMP NEWSN2 ;SET UP FOR SNAPS TO START HERE + +;KILLDISPLAY +; USER WANTS TO GIVE UP HIS DISPLAY +KILLDISPLAY: +KILLD1: +.IIF NZ GTL,CLR GTLDF ;IT'S NOT A GTL DISPLAY THEN + + BIT #DISPF,DIVOWN + BEQ KILLDR ;USER DOESN'T HAVE DISPLAY +KILLD2: CLR A ;GET USER NUMBER + CLR SNLIST ;CLEAR SNAPS + BIC #DISPF,DIVOWN ;CLEAR DISPLAY FLAG + BIC #DISPF,DFLAGS + JSR PC,.GCOLL + +.IFNZ TVS +.IIF NZ COLOR,JSR PC,FLSBUF ;GET RID OF COLOR BUFFERS, IF ANY + BIT #TVF,DFLAGS ;ARE WE USING TV? + BEQ KILLD3 ;NO +KILLD9: CLR B + JSR PC,CRECHO ;CREATE AN ECHO AREA OF SIZE 0 IE NO ECHO AREA + BR KILLDR ;DON'T FLUSH CAP +KILLD3: +.ENDC + + MOV DISCAP,A + JSR PC,DELCAP + CLR DISCAP +KILLDR: SEZ + RTS PC +.IFTF +DCHKPL: +.IFNZ NPLOT + BIT #PLOTF,DFLAGS ;USING PLOTTER? + BEQ 1$ + RTS PC +.ENDC +1$: +.IFNZ GTL + TST GTLDF ;USING THE 2500? + BEQ DCHK + RTS PC +.ENDC +DCHK: +.IFF + ERROR+VTU +.IFT + BIT #DISPF,DFLAGS + BNE DCHK1 + PUSH B + CLR B ;SPECIFY A SMALL DISPLAY BUFFER + + CLR A ;SET FLAG FOR NOT KILLING OTHER DEVICES + COM A + + JSR PC,STRTD0 ;STARISPLAY + SPOP B + RTS PC +DCHK1: + .IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV + BNE KILLDR ;YES JUST RETURN + .ENDC + CMP NADXY,#20 + BLT KILLDR ;DON'T BOTHER TRYING TO COMPRESS ADDXY'S + JSR PC,DSGC8 ;TRY TO COLLAPSE + BR KILLDR + +.ENDC + TBOX: JSR PC,NODEV + CLR E + MOV #PTBTAB,B + MOV #4,A +TBOX3: DEC A + BLT TBOX4 +TBOX7: SPUSH A + SPUSH E + PRTXT ^\PORT \ + JSR PC,PRDN + PRTXT ^\: ?\ + JSR PC,QUEST + SPOP E + SPOP A + CMP D,#'P ;IS IT A PLOTTER + BEQ TPLOT + CMP D,#'N ;IS IT NULL + BEQ TNUL + CMP D,#'C ;IS IT HIS CONSOLE + BEQ TCON + CMP D,#'T ;IS IT A TURTLE + BEQ TTUR + CMP D,#'M ;IS IT A MUSIC BOX + BEQ TMUS + CMP D,#7 + BEQ TBOX6 + SPUSH A + PRTXT ^\ ? \ + SPOP A + BR TBOX7 +TMUS: MOV #PMBOX,(B)+ + BR TBOX3 +TNUL: CLR (B)+ + BR TBOX3 +TCON: MOV #CONSO,(B)+ + BR TBOX3 +TTUR: MOV E,(B) + BIS #TURT,(B)+ + INC E + BR TBOX3 +TPLOT: MOV #PLOTT,(B)+ + BR TBOX3 +TBOX4: TST -(P) + SPUSH #.TIRST + SPUSH TYOCP + BIS #.TTBIS*400,(P) + $INVOK + SUB #4,P + SAVE TYOCP + BIS #.TTRD*400,(P) + $INVOK + SPOP OTTYST + MOV #CONSO,C + MOV #-1,PTBF + JSR PC,TBINIT + BEQ TBOX5 + SEZ + RTS PC +TBOX5: JSR PC,NOTBOX + ERROR+TDE +TBOX6: JSR PC,NOTBOX + ERROR+BRK + +NOTBOX: JSR PC,NODEV + CLR PTBF + SEZ + RTS PC + + + +.IFNZ NDISP + +CTRDIS: BIT #DISPF,DIVOWN ;DOES HE OWN A DISPLAY? + BEQ CTRERR ;NO + BIT #DISPF,DFLAGS ;IS HE CONTROLLING IT NOW? + BNE CTRRET ;YES,DONE + BIC #,DFLAGS + BIS #DISPF,DFLAGS ;SET FLAG FOR CONTROLLING DISPLAY + BIS DPENP,DFLAGS ;SET DISPLAY PEN POSITION + SEZ + RTS PC +.ENDC + +CTRTUR: BIT #TURTF,DIVOWN ;DOES HE OWN A TURTLE? + BNE .+4 ;NO,ERROR +CTRERR: ERROR+VTD + BIC #,DFLAGS + BIS #TURTF,DFLAGS ;SET FLAG FOR CONTROLLING TURTLE + JSR PC,G1NARG ;WHICH TURTLE DOES HE WANT TO CONTROL? + TST B ;TEST TURTLE NO. + BGE .+4 ;IT'S OKAY SO FAR +CTRER2: ERROR+ITN ;INVALID TURTLE NUMBER + DEC B ;TO START TO TURN INTO AN INDEX +; CMP B,#NTUR-1 + BGT CTRER2 ;IT WAS TO LARGE + ASL B ;TURN IT INTO A WORD INDEX + BNE CTRERR ;NOPE + MOV STURF(B),TURF +CTRRET: SEZ + RTS PC + +.IFNZ NPLOT + +CTRPLT: BIT #PLOTF,DIVOWN ;DOES HE OWN THE PLOTTER? + BEQ CTRERR ;NOPE + BIT #PLOTF,DFLAGS ;IS HE CONTROLLING IT NOW? + BNE CTRRET ;YES,DONE + BIC #,DFLAGS + BIS PLPENP,DFLAGS ;SET PLOTTER PEN POSITION + BIS #PLOTF,DFLAGS ;SET FLAG FOR CONTROLLING PLOTTER + SEZ + RTS PC + + +.ENDC + +.IFNZ + + +.IFZ FPPF + +DBK: NEG B +;DISPLAY FORWARD AND BACK +DFD: MOV B,C + CLR B + TST C + BGE DFD1 ;IF ARG IS NEG, + COM B ;SET B = -1 + CLR A ;CLEAR FLAG +DFD1: MOV #CURX,D + JSR PC,MULSIN ;PUTS DX IN E,,F + SDPADD (D)+,(D)+,E,F ;NEW X + PUSH F ;FRACTION PART + SPUSH E ;INTEGER PART + JSR PC,MULCOS ;DY IS IN E,,F + SDPADD (D),(D)+,E,F ;NEW Y + SPUSH F + SPUSH E + BR SETMOV + +.IFF + +DBK: NEGF FA +DFD: +.IFZ DDF + LDCFD COSA,FB + MULF FA,FB + LDCFD CURY,FC +.IFF + JSR PC,GTCURX ;IS HE CONTROLLING PLOTTER OR DISPLAY? + LDCFD COSA(F),FB ;COSINE OF ANGLE -> FB + MULF FA,FB ;DY -> FB + LDCFD CURY(F),FC ;CURY -> FC +.IFTF + ADDF FC,FB ;GET NEW Y IN FB + STCDF FB,-(P) ;PUT NEW Y ON STACK +.IFT + LDCFD SINA,FB + MULF FA,FB ;DX IN FB + LDCFD CURX,FC ;CURRENT X IN FC +.IFF + LDCFD SINA(F),FB ;SINE OF ANGLE -> FB + MULF FA,FB ;DX -> FB + LDCFD (F),FC ;CURX -> FC +.ENDC + ADDF FC,FB ;GET NEW X IN FB + STCDF FB,-(P) ;PUT NEW X ON STACK + BR SETMOV + +.ENDC +.IFNZ DDF + ;PUTS THE ADDRESS OF THE CURX OF DISPLAY IN F + ;IF HE OWN A DISPLAY, ELSE PUTS CURX OF PLOTTER IN F +.IFNZ NDISP +GTCURX: BIT #DISPF,DFLAGS ;DOES HE OWN A DISPLAY? + BNE DISP ;YES + TST GTLDF + BNE DISP + MOV #PCURX,F ;PUT ADDRESS OF PCURX IN F + BR DISP1 +DISP: MOV #DCURX,F ;PUT ADDRESS OF DCURX IN F +DISP1: RTS PC +.IFF +GTCURX: MOV #PCURX,F + RTS PC +.ENDC +.ENDC + + +.IFZ FPPF + + +SETX: JSR PC,DCHKPL + JSR PC,G1NARG ;;NEW X IN B + CLR -(SP) ;FRACTION PART OF NEW X + PUSH B ;INTEGER PART + SPUSH CURY ;NEW Y UNCHANGED + SPUSH CURY+2 + BR SETMOV + +SETY: JSR PC,DCHKPL + JSR PC,G1NARG + PUSH CURX ;NEW X UNCHANGED + SPUSH CURX+2 + CLR -(SP) ;FRACTION PART OF NEW Y + SPUSH B ;INTEGER PART OF NEW Y + BR SETMOV + +SETXY: GTJUMP GTSXY + JSR PC,DCHKPL + JSR PC,G2NARG + CLR -(SP) ;FRATION PART OF NEW X + PUSH B ;INTEGER PART + CLR -(SP) ;FRACTION PART OF NEW Y + SPUSH A ;INTEGER PART +SETMOV: JSR PC,MOVETO + RTS PC + +SETTURTLE: + JSR PC,DCHKPL + MOV @S,C + JSR PC,LD3NUM ;LOAD D,E,F +SETT1: PUSH F ;SAVE NEW ANGLE + JSR PC,SPOPT ;POP OFF ARG + CLR -(SP) ;FRACTION PART OF NEW X + SPUSH D ;INTEGER + CLR -(SP) ;FRACTION PART OF NEW Y + SPUSH E + CLR A ;A FLAG + JSR PC,MOVETO ;MOVE TO NEWX,NEWY + SPOP B ;NEW HEADING + JMP DRT.HD ;SET HEADING + +.IFF +SETX: JSR PC,DCHKPL +.IFZ DDF + SPUSH CURY+2 + SPUSH CURY +.IFF + JSR PC,GTCURX + SPUSH CURY+2(F) ;PUT CURY ON STACK + SPUSH CURY(F) +.IFTF + JSR PC,GARG ;PUT NEWX ON STACK + BR SETMOV +SETY: JSR PC,DCHKPL + JSR PC,GARG ;PUT NEW Y ON STACK +.IFT + SPUSH CURX+2 + SPUSH CURX +.IFF + JSR PC,GTCURX + SPUSH 2(F) ;PUT CURX ON STACK + SPUSH (F) +.ENDC + BR SETMOV +SETXY: GTJUMP GTSXY + JSR PC,DCHKPL + JSR PC,GARG ;PUT Y ON + JSR PC,GARG ;PUT X ON +SETMOV: JSR PC,MOVETO + RTS PC + +SETTURTLE: + MOV @S,C + JSR PC,.GFLST ;FA <- NEWX + LDD A,B ;FB <- NEWX + JSR PC,.GFLST ;FA <- NEWY + BIT #7777,C ;ANY MORE LIST? + BEQ SETT1 ;NO?! + JSR PC,.LOADC ;GET POINTER TO ANGLE + BIT #7777,A ;ANY MORE LIST? (SHOULDN'T BE) + BNE SETT1 ;THERE IS?? + MOV #SNUM,A ;TAKE POINTER AND TRY TO + JSR PC,CONVER ;CONVERT IT TO A SNUM + BNE .+4 +SETT1: ERROR+WTA + SPUSH B ;STORE ANGLE + STCDF FA,-(P) ;STORE NEWY + STCDF FB,-(P) ;STORE NEWX +SETT2: JSR PC,DCHKPL + CLR A ;SET A FLAG + JSR PC,MOVETO ;MOVE IT + SPOP B ;POP ANGLE + JMP DRT.HD + +.GFLST: BIT #7777,C ;GETS FLOATING NUMBER OUT OF LIST + BEQ SETT1 ;EMPTY LIST + JSR PC,.LOADC ;GET NODE IN A AND B + MOV A,C ;GET POINTER TO REST OF LIST IN C + JSR PC,G1NUMS ;GET FNUM POINTED TO BY B INTO FA + BEQ SETT1 + RTS PC + +GARG: SPOP FNPDL+4 ;SO THAT THE JMP WILL WORK BELOW + SPUSH A ;STORES REGISTERS AND GETS NUMBER IN FA + SPUSH B + SPUSH F + JSR PC,G1NUM ;FA <- FNUM POINTER TO BY B + BEQ SETT1 + SPOP F ;RESTORE REGISTERS + SPOP B + SPOP A + STCDF FA,-(P) ;PUT FA ON STACK + JMP @FNPDL+4 ;DOES A RTS PC + +.ENDC + +;CALL WITH NEWX AND NEWY ON THE STACK + + + + +MOVETO: JSR PC,PPOPT ;INSURE ENOPUGH STACK IS IN CORE + .IFNZ NPLOT +.IFNZ NDISP + BIT #PLOTF,DFLAGS ;USING PLOTTER? + BEQ MTO.09 ;IF NOT,SKIP ALL THIS +.ENDC + + +.IFZ FPPF + + MOV 2(P),C ;INT OF Y + MOV 4(P),A ;FRACTION Y + MOV 6(P),B ;INT OF X + MOV 10(P),D ;FRACTION X + ASL A + ADC C ;ROUND Y + ASL D + ADC B ;ROUND X + CMP B,#128. ;CHECK IF EXCEEDS PLOTTER BOUNDS + BGE MTO.03 + CMP B,#-128. + BLT MTO.03 + CMP C,#128. ;NOW CHECK Y BOUNDS + BGE MTO.03 + CMP C,#-128. + BLT MTO.03 + JSR PC,MTO.02 + JMP MTO.R +;SEND OUT PLOTTER CHARACTERS + +.IFF + + LDCFD 2(P),FA ;LOAD NEWX + LDCFD 6(P),FB ;LOAD NEWY + STF FA,FD + JSR PC,CHKBND ;CHECK BOUNDS + STF FB,FD + JSR PC,CHKBND ;CHECK BOUNDS + SETI + STCFI FA,B ;PUT NEWX INTO B + STCFI FB,C ;PUT NEWY INTO C + SETL + ASR B ;ROUND NEWX + ADC B + ASR C ;ROUND NEWY + ADC C + JSR PC,MTO.02 ;MOVE IT + JMP MTO.R ;STORE AWAY NEWX AND NEWY +.IFZ DDF + +CHKPL: CMPF #42000,FC + CFCC + BLT MTO.03 + CMPF #142000,FC + CFCC + BGT MTO.03 + RTS PC +.ENDC + +.ENDC + +MTO.02: MOV #35,D ;PRIMING CHARACTER + MOV PLTDVN,E + SPUSH C + MOV #PLOTT,C + JSR PC,TBTYO ;SEND TO TTY + JSR PC,MTO.04 ;SEND NEW X TO PLOTTER + JSR PC,PLT67 + JSR PC,TBTYO + SPOP B + JSR PC,MTO.04 ;SEND NEW Y TO PLOTTER + JSR PC,PLT67 + JSR PC,TBTYO +.IIF NZ PTBOX, JSR PC,TBREST + RTS PC +MTO.03: ERROR+OOB +MTO.04: MOV B,D ;SEND LOW ORDER 6 BITS + BIC #177700,D + JSR PC,PLT67 + JSR PC,TBTYO + MOV B,D ;SEND REMAINING 2 BITS + ASL D + ASL D + SWAB D + BIC #177774,D + BIT #PENUF,DFLAGS ;SEND PENUP INFO + BEQ MTO.05 + BIS #40,D ;SET PENUP BIT +MTO.05: RTS PC + +PLT67: BIT #40,D ;SET BIT 6 TO COMP OF BIT 7 + BNE PLT671 + BIS #100,D +PLT671: RTS PC + + +.ENDC + .IFNZ NDISP + +.IFZ FPPF + +MTO.09: MOV SP,F + TST (F)+ ;POINT TO ARGS + MOV (F)+,B ;INTEGER PART OF NEW Y + MOV (F)+,C ;FRACTION PART OF NEW Y + JSR PC,CHKBND ;CHECK TO SEE IF IN BOUNDS + MOV B,E ;ROUNDED NEWY + MOV (F)+,B ;INTEGER PART OF NEW X + MOV (F),C ;FRACTION PART OF NEW X + JSR PC,CHKBND + MOV B,D ;ROUNDED NEWX +;GET D_DX AND E_DY + MOV #CURX,F + ASL (F)+ ;FRACTION OF CURX + ADC (F) ;ROUND CURX + SUB (F)+,D ;DX + ASL (F)+ + ADC (F) + SUB (F),E ;DY + +.IFF + +MTO.09: + .IFNZ TVS + BIT #TVF,DFLAGS + BEQ MTO.10 + SETF + LDF DCURX,FA ;FROM X + LDF DCURY,FB ;FROM Y + REST F ;THE RETURN ADDRESS + LDF (P)+,FC ;TO X + LDF (P)+,FD ;TO Y + SAVE F ;PUT THE RETURN ADDRESS BACK + JMP VECTOR ;DRAW THE VECTOR +MTO.10: + .ENDC + + MOV P,F ;SO IT CAN DO POPS W/O DISTURBING THE STACK + TST (F)+ ;TO GET AROUND THE PC + LDCFD (F)+,FA ;GET NEW X + STF FA,FD ;TO CHECK IF IN BOUNDS + JSR PC,CHKBND + LDCFD (F)+,FB ;GET NEW Y + STF FB,FD ;TO CHECK IF IN BOUNDS + JSR PC,CHKBND +.IIF Z DDF, MOV #RCURX,F +.IFNZ DDF + JSR PC,GTCURX ;GET APPROPRIATE VARIABLES + ADD #RCURX,F ;TO TELL WHERE TO PUT ROUNDED FA AND FB +.ENDC + JSR PC,ROUND ;ROUND FA AND FB + SETF + SUBF (F)+,FA ;FA <- NEWX - CURX + SUBF (F)+,FB ;FB <- NEWY - CURY + SETD + JSR PC,MOD1K ;PERFORM A MODULAR 32K. (ANY BETTER IDEAS?) + SETI + STCFI FA,D ;PUT DX IN D + STCFI FB,E ;PUT DY IN E + SETL + +.ENDC + + BNE MTO.1 ;CHECK FOR DX=DY=0 + TST D + BEQ MTO.R ;JUST RETURN + +MTO.1: BIT #PENUF,DFLAGS ;IS PEN UP? + BNE MTO.PU ;YES +;FALLS THROUGH + ;FALLS IN +;THE PEN IS DOWN + SPUSH DIREC + JSR PC,XYDIR ;CALCULATE DIREC + JSR PC,DR.LIN ;AND DRAW LINE!! + SPOP DIREC + +;RETURN. SET CURX & CURY TO NEWX & NEWY + + +.ENDC + +.IFZ FPPF + +MTO.R: POP A ;RETURN ADDRESS + MOV #CURY+2,B + SPOP (B) ;PUT NEWX AND NEWY IN CURX AND CURY + SPOP -(B) + SPOP -(B) + SPOP -(B) + JMP (A) + +.IFF + +MTO.R: POP A +.IFZ DDF + MOV #CURX,B +.IFF + JSR PC,GTCURX ;GET APPROPRIATE SET OF VARIABLES + MOV F,B ;B <- POINTER TO VARIABLES +.ENDC + SPOP (B)+ ;PUT NEWX AND NEWY IN CURX AND CURY + SPOP (B)+ + SPOP (B)+ + SPOP (B)+ + JSR PC,ROUNDER ;ROUND AND PUT IN RCURX AND RCURY + SEZ + JMP (A) ;DOES AN RTS!!? + +ROUNDER: ;PUTS ROUNDED CURX AND CURY INTO RCURX AND RCURY +.IFZ DDF + MOV #CURX,B + MOV #RCURX,F +.IFF + JSR PC,GTCURX ;GET APPROPRIATE VARIABLES + MOV F,B ;B <- POINTER TO VARIABLES + ADD #RCURX,F ;MAKE F POINT TO RCURX +.ENDC + LDCFD (B)+,FA ;FA <-CURX + LDCFD (B)+,FB ;FB <- CURY + JSR PC,ROUND ;ROUND FA AND FB + STCDF FA,(F)+ ;RCURX <- ROUNDED CURX + STCDF FB,(F)+ ;RCURY <- ROUNDED CURY + RTS PC + + ;ROUNDS FA AND FB +ROUND: ADDF #40000,FA ;FA <- FA + 1/2 + STCFI FA,-(P) ;INTEGERIZE FA + BCS EROOB ;TOO BIG + LDCIF (P)+,FA ;FA <- INTEGER (FA) + CFCC ;IS FA > 0? + BGE 1$ ;YES + SUBF #40200,FA ;FA <- FA - 1 (TO ROUND AWAY FROM 0) +1$: ADDF #40000,FB ;REPEAT SAME PROCESS FOR FB + STCFI FB,-(P) + BCS EROOB + LDCIF (P)+,FB + CFCC + BGE 2$ + SUBF #40200,FB +2$: RTS PC +EROOB: ERROR+OOB + +MOD1K: LDD FB,FC + MODF #34600,FC ;DIVIDES BY 2^16 (FC <- ONLY FRACTIONAL PART) + CFCC + BEQ MODK1 ;IT WAS ZERO OR UNDERFLOWED + MULF #43600,FC ;FRACTION * 2^16 + LDD FC,FB ;PUT IT BACK NOW +MODK1: LDD FA,FC ;NOW DO IT TO FA + MODF #34600,FC + CFCC + BEQ MODK2 + MULF #43600,FC + LDD FC,FA +MODK2: RTS PC + +.ENDC + +.ENDC + .IFNZ NDISP + + +;THE PEN IS UP +;PUT ADDX AND ADDY COMMANDS INTO DISPLAY LIST +MTO.PU: SPUSH #MTO.R ;SO RTS PC'S BELOW WILL WORK (GROAN !!!) + MOV STT,A ;POINTER TO TOP OF STATIC DISPLAY ALLOCATION + CMP -(A),#ADDY + BLO MTO.AD ;PREVIOUS STUFF NOT ADDS ANYWAY + CMP -(A),#ADDY ;IS THE NEXT TO LAST DCODE AN ADD,TOO ? + BLO MTO.AD ;NO + CMP A,SNABOT ;DON'T COMPRESS ACROSS SNAP BOTTOM + BLO MTO.AD ;NO +;THERE ARE TWO ADD COMMANDS IN A ROW + JSR PC,MTO.AS ;TAKE CARE OF FIRST ADD + JSR PC,MTO.AS ;AND SECOND ADD + BR MTO.R1 + + +;MTO.AS ADDS THE DELTA X OF AN ADD COMMAND TO THE NEW DX OR DY +MTO.AS: CMP (A),#ADDX ;ADDX IS THE BIGGER OF THE ADDS + BHIS 1$ + ADD (A)+,E ;DY + RTS PC +1$: ADD (A)+,D + RTS PC + + + +;HAVE TO EXPAND STATIC AREA AND PUT IN ADD COMMANDS +MTO.AD: MOV #STT,A + JSR PC,STXPND ;STATIC AREA EXPAND + +MTO.RM: MOV A,STT ;A WAS SET IN STXPND + MOV PUSHJT,(A) ;DISPLAY JUMP TO TURTLE +MTO.R1: BIC #176000,D ;IN CASE EITHER DX OR DY WERE NEGATIVE + BIC #176000,E ;CLEAR THE TOP 6 BITS + BIS #ADDY,E ;TURN E INTO ADDY COMMAND + MOV E,-(A) ;STORE IN DLIST + BIS #ADDX,D ;TURN D INTO ADDX COMMAND + MOV D,-(A) ;STORE IN DLIST + CLR DFBCNT + RTS PC + +.ENDC + .IFNZ + +.IFZ FPPF + +DLT: NEG B + +;DISPLAY RIGHT AND LEFT + +DRT: ADD CURA,B + +.IFF + +DLT: NEGF FA +DRT: SETI + STCFI FA,B + SETL + BCC 1$ ;NUMBER TOO LARGE??, NOPE + ERROR+TGDZ ;TURTLE GETTING DIZZY +1$: +.IFZ DDF + ADD CURA,B +.IFF + JSR PC,GTCURX ;GET POINTER TO APPROPRIATE VARIABLES + ADD CURA(F),B ;B <- NEWA + CURA +.ENDC + +.ENDC +DRT.HD: JSR PC,MOD360 ;SET B=B MOD 360 + +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV? + BEQ 1$ ;NO + JMP TVHEAD ;TV VERSION OF HEADING UPDATE +1$: +.ENDC + +.IIF Z DDF, MOV B,CURA +.IFNZ DDF + JSR PC,GTCURX + MOV B,CURA(F) ;MOVE NEWLY COMPUTED ANGLE TO CURA +.ENDC + +;DRAW THE TURTLE IF IT'S BEING SHOWN +TURDO: JSR PC,ANGCRP ;DO ALL THE ANGLE CRAP. + .IFNZ NPLOT + BIT #PLOTF,DFLAGS ;USING PLOTTER? + BNE DRTRET ;YES, SO RETURN + .ENDC +.IFZ NDISP + ERROR+VTU +.IFF + BIT #HIDETF,DFLAGS ;IS THE TURTLE BEING HIDDEN ? + BNE DRTRET ;YES. SO RETURN +;THE TURTLE IS BEING SHOWN. SO DRAW THE TURTLE + JSR PC,DR.TUR +.ENDC + +DRTRET: SEZ + RTS PC + +;SETHEAD +; LIKE RIGHT, EXCEPT SET CURA TO ARGUMENT +SETHEAD: GTJUMP GTSETH + JSR PC,DCHKPL + JSR PC,G1NARG ;NUMERIC ARGUMENT IN B + BR DRT.HD ;JUMP INTO RIGHT + +;WRAPAROUND +.IFNZ NDISP + +WRAP: +.IFNZ TVS + BIT #TVF, DFLAGS + BEQ WRNTVE + JSR PC, ETVTUR +WRNTVE: +.ENDC + BIS #WRAPF, DFLAGS + BIC #CLIPF, DFLAGS +.IFNZ TVS + BIT #TVF, DFLAGS + BEQ WRNTVD + JMP DTVTUR +WRNTVD: +.ENDC + SEZ + RTS PC + +;CLIPMODE +.IFNZ TVS + +CLIP: JSR PC,TVTEST ;TVS ONLY + BIT #TVF, DFLAGS + BEQ CLNTVE + JSR PC, ETVTUR +CLNTVE: + BIC #WRAPF,DFLAGS + BIS #CLIPF,DFLAGS + BIT #TVF, DFLAGS + BEQ CLNTVD + JMP DTVTUR +CLNTVD: + SEZ + RTS PC + +NOCLIP: JSR PC, TVTEST +.ENDC + +NOWRAP: +.IFNZ TVS + BIT #TVF, DFLAGS + BEQ BHNTVE + JSR PC, ETVTUR ;Erase turtle over this. +BHNTVE: +.ENDC + BIC #, DFLAGS + SETF ;In WRAP or CLIP modes, coordinates may be + SETI ;outside screen. Restore to within bounds. + LDF DCURX, FB ;Subtract left edge to move origin to left. + SUBF TRLEFT, FB ;Smash down coordinate modulo screen size. + LDCIF #1., FA ;Reciprocate so MODF does division by TRSIZX. + DIVF TRSIZX, FA + MODF FA, FB ;FB=1 is odd, fractional part of product in FB. + MULF TRSIZX, FB + CFCC + BGE BHXPOS + ADDF TRSIZX, FB +BHXPOS: ADDF TRLEFT, FB ;Move origin back. + STF FB, DCURX ;Save as new XCOR. + LDF DCURY, FB ;Similarly for YCOR. + SUBF TRBOT, FB + LDCIF #1., FA + DIVF TRSIZY, FA + MODF FA, FB + MULF TRSIZY, FB + CFCC + BGE BHYPOS + ADDF TRSIZY, FB +BHYPOS: ADDF TRBOT, FB + STF FB, DCURY +.IFNZ TVS + BIT #TVF, DFLAGS + BEQ BHNTVD + JMP DTVTUR +BHNTVD: +.ENDC + SEZ + RTS PC + + +.IFZ FPPF + + + +;HERE +; OUTPUT A SENTENCE OF CURX,CURY,CURA +HERE: GTJUMP GTHERE + JSR PC,DCHKPL + MOV #CURX,D + JSR PC,PSHINT ;PUSH INTEGER OF CURX ONTO S-PDL + JSR PC,PSHINT ;PUSH INTEGER OF CURY + MOV (D),B ;CURRENT ANGLE +HERE.1: JSR PC,PSHNUM ;PUSH CURRENT ANGLE +HERE.2: MOV #3,D ;PUSH 3 ONTO P-PDL + JMP SENT. + + +;XCOR +; OUTPUT THE X COORDINATE +XCOR: GTJUMP GTXCOR + JSR PC,DCHKPL + MOV #CURX,D + BR YCOR1 +;YCOR +; OUTPUT THE Y COORDINATE +YCOR: GTJUMP GTYCOR + JSR PC,DCHKPL + MOV #CURY,D +YCOR1: JMP R1INT ;RETURN INTEGER + + +;HEADING +; RETURN THE CURRENT ANGLE +HEADIN: GTJUMP GTHEAD + JSR PC,DCHKPL + MOV CURA,B + JMP R1NARG + ;HOME -- SAME AS SETT [0 0 0] +HOME: GTJUMP GTHME + JSR PC,DCHKPL + JSR PC,SPUSHT + CLR D + CLR E + CLR F + JMP SETT1 + +.IFF + +HERE: GTJUMP GTHERE + JSR PC,DCHKPL ;DOES HE OWN DISPLAY OR PLOTTER? +.IFZ DDF + MOV #CURX,D +.IFF + JSR PC,GTCURX ;GET APPROPRIATE VARIABLES +.ENDC + JSR PC,WHOPIE ;PUT (F) INTO A NODE, POINTER IN B + PUSHS B ;STORE POINTER TO FNUMS ON STACK + JSR PC,WHOPIE ;DO IT AGAIN + PUSHS B +.IIF Z DDF, MOV (D),B ;STORE ANGLE (SNUM) ON STACK +.IIF NZ DDF, MOV (F),B ;PUT ANGLE (SNUM) IN B + JSR PC,PSHNUM ;PUT SNUM IN B ON S-PDL + MOV #3,D ;PUSH A FLAG ON + JMP SENT. ;CHANGE THE THREE THINGS INTO A SENTENCE + +XCOR: GTJUMP GTXCOR + JSR PC,DCHKPL ;DOES HE OWN A DISPLAY OR PLOTTER? +.IIF Z DDF, MOV #CURX,D ;PUT POINTER TO CURRENT X IN D +.IIF NZ DDF, JSR PC,GTCURX ;GET POINTER TO APPROPRIATE CURX + BR YCOR1 ;GET NUMBER AND RETURN + +YCOR: GTJUMP GTYCOR + JSR PC,DCHKPL ;DOES HE OWN A DISPLAY OR PLOTTER? +.IFZ DDF + MOV #CURY,D ;PUT POINTER TO CURRENT Y IN D +.IFF + JSR PC,GTCURX ;GET APPROPRIATE POINTER TO CURX + ADD #CURY,F ;MAKE F POINT TO CURY +.ENDC +YCOR1: JSR PC,WHOPIE ;PUT NUMBER INTO A NODE,POINTER RETURNED IN B + JMP ORTB ;PUT POINTER IN B ON S-PDL + +HEADIN: GTJUMP GTHEAD + JSR PC,DCHKPL ;DOES HE OWN A DISPLAY OR PLOTTER? +.IFZ DDF + MOV CURA,B ;PUT POINTER TO ANGLE IN B +.IFF + JSR PC,GTCURX ;GET APPROPRIATE POINTER TO CURX + ADD #CURA,F ;MAKE F POINT TO CURA + MOV (F),B ;MOVE CURA TO B +.ENDC + JMP R1NARG ;RETURN B + +HOME: GTJUMP GTHME + CLR -(P) ;SETTURTLE [0 0 0] + CLR -(P) + CLR -(P) + CLR -(P) + CLR -(P) + JMP SETT2 ;SET THE TURTLE! + +.ENDC + +;PENP +;RETURNS TRUE IF THE PEN IS DOWN +;RETURNS FALSE IF IT IS UP +PENP: JSR PC,DCHKPL ;DOES HE OWN A DISPLAY OR PLOTTER? + BIT #PENUF,DFLAGS ;IS THE PEN UP? + BNE PENP1 ;YES + JMP RTTRUE ;NO, RETURN TRUE +PENP1: JMP RTFALS ;YES, RETURN FALSE + .IFNZ NDISP + + +; HIDETURTLE +HIDETURTLE: + BIT #HIDETF, DFLAGS + BNE STRETURN + GTJUMP GTHIDE + JSR PC,DCHK ;DOES HE OWN A DISPLAY?? + +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV? + BEQ 1$ ;NO + JMP TVHIDE ;YES, DO THINGS FOR TV +1$: +.ENDC + + BIS #HIDETF,DFLAGS ;SET THE HIDETURTLE FLAG + MOV #DPOP!DSTOP,@TUB + BR STRETURN + + +; SHOWTURTLE +SHOWTURTLE: + BIT #HIDETF, DFLAGS + BEQ STRETURN + GTJUMP GTSHOW + JSR PC,DCHK ;DOES HE OWN A DISPLAY? + +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV + BEQ NTVST ;NO + JMP TVSHOW ;YES, SHOW THE TV TURTLE +.ENDC +;HAVE TO DRAW THE TURTLE +NTVST: BIC #HIDETF,DFLAGS ;CLEAR THE FLAG FIRST + JSR PC,DR.TUR +STRETURN: + SEZ + RTS PC + +.ENDC + + +; DISPLAY PENUP +DPU: BIS #PENUF,DFLAGS ;SET PEN UP FLAG +.IFNZ TVS + BIC #, DFLAGS + MOV #-1., WINDATA +.ENDC +.IFNZ DDF + BIT #DISPF,DFLAGS ;IS HE CONTROLLING A DISPLAY? + BEQ DPU1 ;NO + BIS #PENUF,DPENP ;SET PEN UP FLAG IN DISPLAY VARIABLES + BR DPR ;RETURN +DPU1: BIS #PENUF,PLPENP ;SET PEN UP FLAG IN PLOTTER VARIABLES +.ENDC +DPU3: BIT #DISPF,DFLAGS ;DISPLAY? + BNE DPU2 ;YES, FORGET IT +.IFZ DDF + SPUSH CURY+2 + SPUSH CURY + SPUSH CURX+2 + SPUSH CURX +.IFF + SPUSH PCURY+2 + SPUSH PCURY + SPUSH PCURX+2 + SPUSH PCURX +.ENDC + JSR PC,MOVETO ;HAVE TO SEND MOVE COMMAND TO PLOTTER TO TOGGLE PEN +DPU2: + SEZ + RTS PC + + +;Display PENDOWN + +DPD: BIC #, DFLAGS ;Clear display pen up flag. +.IFNZ TVS + BIT #TVF,DFLAGS ;KILL + BEQ DPDHEN ;HENRY +.IFNZ COLOR + BIT #COLORF, DFLAGS + BEQ DPDBW +DPDCOL: JSR PC, SELPEN ;(SELECT-COLOR :PENNUMBER) + SEZ + RTS PC +.ENDC +DPDBW: JSR PC, IORMODE ;Draw lines in IOR mode. +.ENDC +DPDHEN: +.IFNZ DDF + BIT #DISPF,DFLAGS + BEQ DPD1 + BIC #PENUF,DPENP + BR DPR +DPD1: BIC #PENUF,PLPENP +DPR: +.ENDC + BR DPU2 +.ENDC + + +;Display ERASERDOWN +.IFNZ TVS +ERASED: JSR PC, TVTEST ;Check to see if on a TV. + BIS #, DFLAGS + BIC #XORF, DFLAGS ;Assign flags; Eraser on, pen, xor off. +.IFNZ COLOR +ERDCOL: BIT #COLORF, DFLAGS + BEQ ERDBW + JSR PC, SELERA ;If in color, select eraer color. + BR ERARET +.ENDC ;In B&W, eraser mode check is made by line drawer. +ERDBW: JSR PC, SETMODE ;Eraser needs SET drawmode. +ERARET: SEZ + RTS PC + +XORUP: +ERASEU: + JSR PC, TVTEST + BIS #PENUF, DFLAGS + BIC #, DFLAGS +.IFNZ COLOR + BIT #COLORF, DFLAGS + BEQ ERUBW + JSR PC, SELPEN + BR ERARET +.ENDC +ERUBW: JSR PC,IORMODE + BR ERARET + + +;XORDOWN ROUTINE +XORDOWN: + JSR PC,TVTEST ;IS THIS A TV? + BIS #, DFLAGS ;Pen is now up, xor is down. + BIC #ERASEF, DFLAGS ;Eraser is up. +.IFNZ COLOR + BIT #COLORF, DFLAGS + BNE XDRET +.ENDC + JSR PC, XORMODE ;SET DRAW MODE TO XOR +XDRET: SEZ + RTS PC + +.ENDC + + +.IFNZ NDISP +;CLEARSCREEN--WIPE SCREEN AND RESTORE TURTLE TO [0 0 0] +CLEARSCREEN: GTJUMP GTCLEA + JSR PC,DCHK ;DOES HE OWN A DISPLAY +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV? + BEQ 1$ ;NO + JMP TVCS ;YES, DO THINGS FOR TV +1$: +.ENDC + JSR PC,WC.1 ;WIPE IT CLEAN + SPUSH DFLAGS + MOV #DORBEG,C ;ZERO VARIOUS USER DISPLAY VARS + MOV #DOREND,B ;INCLUDING CURX, CURY AND OTHERS +CSLOOP: CLR (C)+ + CMP C,B + BLT CSLOOP + + SPOP DFLAGS + CLR DFBCNT + JSR PC,TURDO ;DO ANGLE CRAP AND DRAW TURTLE IF SHOWN + MOV STB,STT + MOV PUSHJT,@STB + JSR PC,NEWSN2 ;RECALCULATE STARTING POINT FOR SNAPS + SEZ + RTS PC + + .IFZ FPPF +;SNAP + +SNAP: JSR PC,DCHK ;DOES HE OWN A DISPLAY? + +;FIRST SET UP THE 3 NODE SNAP STRUCTURE ITSELF + JSR PC,PSHNUM ;FIRST NUMBER IS DUMMY FOR NOW +.IIF NZ DDF, MOV #DCURX,D +.IIF Z DDF, MOV #CURX,D + JSR PC,GETINT ;INTEGER OF CURX IN B + SUB OLDX,B ;TO GET DELTA X + JSR PC,PSHNUM ;PUSH ON S-PDL + JSR PC,GETINT ;INTEGER OF CURY + SUB OLDY,B ;TO GET DELTA-Y + JSR PC,PSHNUM + MOV #3,D ;NUMBER OF ARGS TO SENTENCE + JSR PC,SENT. + +.IFF + ;CALCULATES DX AND DY, AND PUTS POINTERS TO THEM ON S-PDL +OLD: JSR PC,(PC) ;DO THIS TWICE + SETF + LDF (D)+,FA ;SECOND TIME IT POINTS TO CURY + SUBF (F)+,FA ;SECOND TIME POINTS TO OLDY + STF FA,-(P) ;PUT DX OR DY ON STACK + SPOP A ;PUT FNUM IN A,,B + SPOP B + SETD + JSR PC,GRBAD ;PUT A,,B IN NODE + BIS #FNUM,C ;SET TYPE + SPUSHS C ;PUT POINTER ON S-PDL + RTS PC + + +SNAP: GTJUMP GTSNP + JSR PC,DCHK ;DOES HE OWN ADISPLAY? +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV + BEQ 2$ ;NO + ERROR+NTVS ;TVS CANNOT DO THIS FUNCTION +2$: +.ENDC +1$: JSR PC,PSHNUM ;PUSH SNAP POINTER +.IIF NZ DDF, MOV #DCURX,D ;D POINTS TO CURX +.IIF Z DDF, MOV #CURX,D ;DITTO + MOV #OLDX,F ;E POINTS TO WHERE SNAP IS TAKEN FROM + JSR PC,OLD ;CALCULATE DX AND DY OF SNAP + MOV #3,D ;SET FLAG FOR SENTENCE + JSR PC,SENT. ;MAKE THE THREE THINGS INTO A SENTENCE + + +.ENDC +;FALLS THROUGH + ;FALLS IN +;NOW GRAB A NODE FOR THE SNLIST HACKING + MOV SNLIST,C ;POINTER TO SNAP LIST + BNE SNAP.2 + MOV #SNUM,A ;FIRST SNAP + CLR B ;CREATE SNAP LIST. FIRST NODE IS A DUMMY + JSR PC,GRBAD + BIS #LIST,C + MOV C,SNLIST +SNAP.2: JSR PC,.LDP1 ;POINTER TO REST OF SNAP LIST + JSR PC,GRBAD ;STORE A NODE + BIS #LIST,C + MOV C,GCP1 ;GARBAGE COLLECT PROTECT + +;NOW TRANSFER THE DISPLAY CODE (YEAH) + MOV SNABOT,D ;BOTTOM OF STUFF TO BE SNAPPED + JSR PC,DYXFR ;TRANSFER THE DCODE. SKIP IF SUCCEEDS + BEQ SNAP.4 ;COULDN'T FIND ENOUGH FREE MEMORY +SNAP.0: TST D ;IF 0 + BEQ SNAP.3 ;NO CODE MOVED + +;CHECK THAT THIS SNAP WON'T CAUSE DISPLAY PDL OVERFLOW + TST -(D) ;POINTER TO SNAP + CMP -(D),#<<&77777>-1> ;DEPTH COUNTER + BLE SNAP.1 + CLR GCP1 + ERROR+STDP ;SNAP TOO DEEP + +;NOW GO BACK AND PUT THE SNAP ADDRESS IN RIGHT PLACES +SNAP.1: TST (D)+ ;POINT D TO REF COUNTER + INC (D)+ ;INC COUNTER THAT SAYS HOW MANY TIMES DISPLAYED + MOV GCP1,C ;NOW HACK SNLIST + MOV D,A + JSR PC,.STP2 ;STORE ADDRESS IN 2ND WORD OF NODE + MOV C,A ;POINTER TO NODE + BIC #170000,A + BIS #SNUM,A + MOV SNLIST,C + JSR PC,.STP1 ;STORE NEW NODE POINTER INTO FIRST NODE OF SNLIST + + CLR GCP1 + + + MOV @S,C ;NOW HACK THE SNAP STRUCTURE + BIC #170000,C + BIS #SNP,C + MOV C,@S ;PUT IN RIGHT DATA TYPE +;PUT ADDRESS OF SNAP INTO FIRST OF STRUCTURE + JSR PC,.LDP2 ;A_POINTER TO FIRST OF STRUCTURE + MOV A,C + CLR A + MOV D,B + BGE SNAP.6 ;SIGN EXTEND ADDRESS + COM A +SNAP.6: JSR PC,.STORE ;STORE ADDRESS OF SNAP AS FIRST OF STRUCTURE + +;NOW COLLAPSE STATIC AREA AND DISPLAY THE SNAP + MOV #SNABOT,A ;MAKE SURE THERE IS ROOM FOR DISPLAY HERE + JSR PC,STXPND + MOV A,STT + MAKEPJ D + MOV PUSHJT,(A) + MOV D,-(A) + CLR -(A) + CLR DFBCNT + CLZ + RTS PC + + +;SINCE NO DISPLAY CODE WAS MOVED, RETURN EMPTY SNAP +SNAP.3: MOV #SNP,@S + CLR GCP1 + CLZ + RTS PC + +SNAP.4: JSR PC,.GCOLL ;TRY TO FREE SOME STORAGE + MOV SNABOT,D + JSR PC,DYXFR ;TRY TO TRANSFER D.CODE AGAIN + BNE SNAP.0 ;SUCCESS! +SNAP.5: CLR GCP1 + ERROR+TML + .IFZ FPPF + +;NEWSNAP +;SET UP FOR NEXT SNAP TO START HERE +NEWSNAP: JSR PC,DCHK +NEWSN1: +.IIF NZ DDF, MOV #DCURX,D ;ENTER HERE AS SUBROUTINE +.IIF Z DDF, MOV #CURX,D ;ENTER HERE AS SUBROUTINE + JSR PC,GETINT ;GET INTEGER OF CURX IN B + MOV B,OLDX + JSR PC,GETINT ;GET INTEGER OF CURY IN B + MOV B,OLDY + +.IFF + +NEWSNAP: JSR PC,DCHK ;DOES HE OWN A DISPLAY? +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV + BEQ 1$ ;NO + ERROR+NTVS ;TVS CANNOT DO THIS FUNCTION +1$: +.ENDC +NEWSN1: ;ENTER HERE AS SUBROUTINE +.IIF NZ DDF, MOV #DCURX,D ;GET POINTER TO CURX +.IIF Z DDF, MOV #CURX,D ;GET POINTER TO CURX + MOV #OLDX,B ;GET POINTER TO OLDX + MOV (D)+,(B)+ ;PUT CURX AND CURY INTO OLDX AND OLDY + MOV (D)+,(B)+ + MOV (D)+,(B)+ + MOV (D)+,(B)+ + +.ENDC + +NEWSN2: MOV STT,SNABOT ;RESET SNAP BOTTOM TO TOP OF DISPLAY + CLR DFBCNT + SEZ + RTS PC ;EITHER RETURN FROM SUBROUTINE , OR JMP NORT + +;DISPLAY A SINGLE SNAP + +DISPLAY: GTJUMP GTDIS + JSR PC,DCHK ;DOES HE OWN A DISPLAY? +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV + BEQ 2$ ;NO + ERROR+NTVS ;TVS CANNOT DO THIS FUNCTION +2$: +.ENDC +1$: JSR PC,G1SNAP ;LOAD D,E,F WITH PTR TO SNAP,CURX,CURY + BEQ D.RET ;RETURNS HERE IF ARG IS EMPTY +.IFZ FPPF + MOV E,B + ADD CURX+2,B + CLR C ;FRACTION PART IS 0 (SEE SNAP) + JSR PC,CHKBND ;IS NEW X COR IN BOUNDS? + MOV F,B + ADD CURY+2,B + JSR PC,CHKBND ;IS NEW Y COR IN BOUNDS? +.IFF + MOV F,B ;PUT POINTER TO DY IN B + JSR PC,G1NUMS ;FA <- DY + BEQ DIPSEY + STF FA,FB ;FB <- DY + MOV E,B ;PUT POINTER TO DX IN B + JSR PC,G1NUMS ;FA <- DX + BNE .+4 +DIPSEY: .BUG. ;NO WAY IT SHOULD FAIL EITHER +.IIF NZ DDF, MOV #DCURX,B ;PUT POINTER TO CURX IN B +.IIF Z DDF, MOV #CURX,B + SETF + ADDF (B)+,FA ;GET NEW XCOR + ADDF (B)+,FB ;GET NEW YCOR + SETD + STF FA,FD ;CHECK TO SEE IF XCOR IS IN BOUNDS + JSR PC,CHKBND + STF FB,FD ;CHECK TO SEE IF YCOR IS IN BOUNDS + JSR PC,CHKBND +.IFTF +;NOW SEE IF THERE'S ENOUGH ROOM IN THE DISPLAY AREA + MOV #STT,A + JSR PC,STXPND ;STATIC AREA EXPAND +;FINALLY, WE CAN PLACE THE PUSHJ TO THE SNAP INTO THE DISPLAY LIST +DISRM: INC -2(D) ;INCREMENT THE REF COUNTER OF THE SNAP + MOV A,STT ;SET STATIC TOP TO HERE IN DLIST + MOV PUSHJT,(A) ;PUT PUSHJ TO TURTLE AT TOP OF DLIST + MAKEPJ D + MOV D,-(A) ;PUT IN THE PUSHJ + CLR -(A) ;PRECEDE BY A NOP + +;NOW, SET CURX AND CURY +.IFT + + ADD E,CURX+2 ;E HAD DX OF THE SNAP + ADD F,CURY+2 ;F HAS DY OF THE SNAP +.IFF + +.IIF NZ DDF, MOV #DCURX,B ;B <- POINTER TO CURX +.IIF Z DDF, MOV #CURX,B + STCDF FA,(B)+ ;PUT NEW XCOR INTO CURX + STCDF FB,(B)+ ;PUT NEW YCOR INTO CURY + JSR PC,ROUNDER ;ROUND CURX,CURY AND PUT INTO RCURX,RCURY + +.ENDC + + CLR DFBCNT +D.RET: JSR PC,SPOPT ;POP S + SEZ + RTS PC + +;WIPE A SNAP + +WIPE: JSR PC,DCHK ;DOES HE OWN A DISPLAY? + +.IFNZ TVS + BIT #TVF,DFLAGS ;IS THIS A TV + BEQ 1$ ;NO + ERROR+NTVS ;TVS CANNOT DO THIS FUNCTION +1$: +.ENDC + + JSR PC,G1SNAP ;LOAD D,E,F WITH PTR TO SNAP, X, Y + BEQ D.RET ;RETURNS HERE IF ARG IS EMPTY + +.IFNZ FPPF + + MOV F,B ;B <- POINTER TO DY OF SNAP + JSR PC,G1NUMS ;FA <- DY + BEQ DIPSEY + LDD FA,FB ;FB <- DY + MOV E,B ;B <- POINTER TO DX + JSR PC,G1NUMS ;FA <- DX + BEQ DIPSEY + JSR PC,MOD1K ;DO A MOD 32K ON FA AND FB + JSR PC,ROUND ;ROUND FA AND FB + SETI + STCFI FA,E ;E <- DX OF THE SNAP + STCFI FB,F ;F <- DY OF SNAP + SETL +.ENDC + BIC #176000,E ;CLEAR TOP 6 BITS + BIS #ADDX,E ;AND TURN INTO ADDX COMMAND + BIC #176000,F ;CLEAR TOP 6 BITS + BIS #ADDY,F ;TURN INTO ADDY + + MOV D,B + TST -(D) ;POINT D TO SNAP'S REF COUNTER + MAKEPJ B ;MAKE B INTO DPUSHJ TO SNAP + MOV STT,A ;POINTER TO TOP OF DISPLAY LIST + MOV STB,C ;POINTER TO BOTTOM OF DLIST + +WIPE.L: CMP A,C ;ARE WE AT THE BOTTOM YET? + BLO D.RET ;YES, SO WE ARE DONE + CMP B,-(A) ;IS THE NEXT WORD A PUSHJ? + BNE WIPE.L ;NO. LOOP BACK AND TRY ANOTHER +;YES! IT IS A PUSHJ +;PUT ADDX AND ADDY COMMANDS INTO DLIST + INC NADXY ;NADXY IS ACOUNTER TO TELL WHEN TO COMPRESS + MOV F,(A) ;INSERT ADDY MADE FROM DY OF SNAP + MOV E,-(A) ;INSERT ADDX MADE FROM DX OF SNAP + + DEC (D) ;DECREMENT REF COUNTER + BR WIPE.L ;AND THEN LOOP BACK TO SEE IF THERE'S ANOTHER +; PUSHJ TO THIS SNAP + + +;WIPE THE ENTIRE DISPLAY + +WIPECL: GTJUMP GTWIPE ;FOR 2500, CLEAR ALL SNAPS + JSR PC,DCHK ;DOES HE OWN A DISPLAY? + +.IFNZ TVS + BIT #TVF,DFLAGS + BEQ 1$ ;NO + JMP TVWC ;TO THE TV FUNCTIONS +1$: +.ENDC + +WC.1: MOV STB,A ;POINTER TO BOTTOM OF DISPLAY LIST + MOV STT,B ;POINTER TO TOP OF DLIST + MOV #100000,E ;SMALLEST DPUSHJ + MOV #140000,F ;SMALLEST COMMAND BIGGER THAN PUSHJ + +WC.LP: CMP B,A ;ARE WE AT BOTTOM YET? + BLOS WC.DUN ;YES, WE ARE DONE + CMP -(B),E ;IS NEXT WORD DOWN A PUSHJ? + BLO WC.LP ;NO, IT'S TOO SMALL + CMP (B),F + BHIS WC.LP ;NO, IT'S TOO BIG +;THIS WORD IS A PUSHJ + MOV (B),D ;MOVE THE PUSHJ COMMAND INTO D + MAKEAD D ;TURN INTO PDP-11 ADDRESS + DEC -(D) ;DECREMENT SNAP'S REF COUNTER + BR WC.LP ;LOOP BACK TO LOOK FOR MORE PUSHJ'S + +;NOW PLACE ADDX AND ADDY COMMANDS IN THE DISPLAY LIST +;SO THAT THE TURTLE WILL STAY AT THE SAME PLACE IT WAS BEFORE THE WIPE + +.IFZ FPPF + +WC.DUN: MOV #CURX,D + JSR PC,GETINT ;GET INTEGER OF CURX IN B + SPUSH B ;SAVE DX + JSR PC,GETINT ;GET INTEGER OF CURY IN B + MOV B,E ;PUT DY IN E + SPOP D ;PUT DX IN B +.IFF +WC.DUN: +.IIF NZ DDF, MOV #RDCURX,F ;F <- POINTER TO RCURX +.IIF Z DDF, MOV #RCURX,F + LDCFD (F)+,FA ;FA <- RCURX + LDCFD (F)+,FB ;FB <- RCURY + JSR PC,MOD1K ;DO A MOD 32K ON FA AND FB + SETI + STCFI FA,D ;F <- RCURX + STCFI FB,E ;E <- RCURY + SETL +.ENDC + MOV STB,STT + JSR PC,MTO.AD ;PUTS THE ADD COMMANDS INTO THE DLIST + JSR PC,NEWSN1 ;SO THAT SNAPS WILL START HERE + + RTS PC + .ENDC +.SBTTL DISPLAY UTILITY ROUTINES + +.IFZ FPPF + + +;CHKBND +; CHECK BOUNDS. ERROR IF B IS OFF SCREEN +; ALSO ROUNDS B,,C +CHKBND: BIT #WRAPF,DFLAGS + BNE CBRND ;GO AND ROUND + CMP B,#200. + BGE CBIBIG ;INTEGER PART MAY BE TOO BIG + CMP B,#-200. + BLT ERROOB ;DUE TO THE FACT THAT FRACTION IS ALWAYS + ;POSITIVE, IF B=-200 THAT GUARANTEES IT IS IN + ;BOUNDS. (I HOPE) +CBRND: ASL C + ADC B + RTS PC +;HERE, THE INTEGER PART IS >= 200. +;SO IF THE FRACTION PART IS NON-ZERO, THAT WILL MEAN THAT THE ENTIRE +;NUMBER IS GREATER THAN 200 +CBIBIG: BGT ERROOB ;INTEGER>200 + TST C + BEQ CBRND +ERROOB: ERROR+OOB + +.IFF + +CHKBND: BIT #PLOTF,DFLAGS ;IS HE USING PLOTTER? + BNE CHK1 ;YES, IGNORE WRAP FLAG + BIT #WRAPF,DFLAGS ;IS HE WRAPPING + BNE CBRND ;YES, DON'T CHECK BOUNDS +CHK1: CMPF #42110,FD ;IS 200 < FD? + CFCC + BLT ERROOB ;YES, ERROR + CMPF #142110,FD ;IS -200 > FD? + CFCC + BGT ERROOB ;YES,ERROR +CBRND: RTS PC +ERROOB: ERROR+OOB ;OUT OF BOUNDS + +.ENDC + +.IFNZ NDISP + +;STATIC AREA EXPAND. +; IS THERE ROOM IN STATIC AREA FOR 2 DISPLAY WORDS? +; RETURN POINTER TO NEW STATIC TOP IN A +STXPND: PUSH A + MOV (A),A ;ROUTINE IS CALLED WITH ADDRESS OF VARIABLE + CMP (A)+,(A)+ ;A _ A+4 + CMP A,DYB ;COMPARE A WITH DYNAMIC BOTTOM + BLO STXPN8 ;THERE'S ROOM! + JSR PC,.GCOLL ;TRY TO FREE SOME STORAGE + MOV @(SP)+,A ;AND TRY AGAIN + CMP (A)+,(A)+ + CMP A,DYB ;COMPARE A WITH DYNAMIC BOTTOM + BLO STXPN9 + ERROR+TML ;TOO MANY LINES +STXPN8: TST (SP)+ ;POP OFF A +STXPN9: RTS PC + +.ENDC + + +.IFZ FPPF + +;MULCOS +; RETURN A*COSINE OF CURA IN B,,C +MULCOS: MOV COSA,F + BR MULCS2 +;MULSIN +; RETURN A*SINE OF CURA IN B,,C +MULSIN: MOV SINA,F +MULCS2: CLR E + ASL F ;TURN INTO BOTTOM HALF OF DP NUMBER + SBC E ;MAKE E NEG. IF F WAS + JSR PC,.DPMUL + NOP 1 + RTS PC +.ENDC + +;ANGCRP +; CALCULATE ANGLE CRAP. +; CALCULATE DIREC, SINA, COSA +ANGCRP: +.IFZ FPPF + CLR E +.IFZ DDF + MOV CURA,F ;DIVIDE CURA BY 90. +.IFF + JSR PC,GTCURX ;GET POINTER TO APPROPRIATE CURX + MOV CURA(F),F ;F <- CURX +.ENDC + DIV #90.,E + MOV F,C ;THE REMAINDER + MOV E,F ;THE QUOTIENT + MOV #90.,E ;THE RIGHT ANGLE + SUB C,E ;NOW E = 90.- REMAINDER + MOV C,A ;A_REMAINDER + JSR PC,SINGET ;D_SIN (A) + MOV D,B + MOV E,A + JSR PC,SINGET + ASL F ;F = 0,1,2,3 + ADD F,PC ;JUMP THROUGH THIS DISPATCH TABLE + BR ACR.D + BR ACRII ;QUADRANT II + BR ACRIII ;QUADRANT III +;FOURTH QUADRANT + MOV B,A ;SIN (A) + MOV D,B ;SIN (90-A) + NEG B ;SINA=-SIN(90-A) IN 4TH QUADRANT + MOV A,D ;AND COSA=SIN(A) IN 4TH QUADRANT + BR ACR.D + +;THE THIRD QUADRANT +ACRIII: NEG B ;SINA = -SIN (A) IN 3RD QUADRANT + NEG D ;COSA = - SIN (90-A) IN 3RD QUADRANT + BR ACR.D + +;SECOND QUADRANT +ACRII: MOV B,A ;SIN (A) + MOV D,B ;SINA = SIN (90-A) IN 2ND QUADRANT + MOV A,D + NEG D ;COSA = -SIN (A) IN 2ND QUADRANT + +;IN THE FIRST QUADRANT +;SINA = SIN (A) AND +;COSA = SIN (90-A) +ACR.D: MOV B,SINA + MOV D,COSA + +;FALLS THROUGH + ;FALLS IN + +;CLACULATE DIREC FROM STUFF LEFT IN F AND C BY ANGCRP +ANGDIR: CMP #45.,C + ADC F ;CARRY SET IF C<45 + ASL F + ASL F + ASL F + MOV F,DIREC + RTS PC + +;GET SIN (A) INTO D. +;THE SINE TABLE HAS ONLY EVEN ANGLES. INTERPOLATE ODD ANGLES. +SINGET: BIT #1,A ;ODD OR EVEN + BEQ AEVEN + ADD #,A ;POINT TO ANGLE AFTER IT + MOV (A),D ;SIN (A+1) + ADD -(A),D ;PLUS SIN (A-1) + ROR D ;DIVIDED BY 2 + RTS PC +AEVEN: MOV SIN(A),D + RTS PC + +.IFF + SETI +.IFZ DDF + LDCIF CURA,FA ;ANGCRP FOR FLOATING DISP +.IFF + JSR PC,GTCURX ;GET POINTER TO APPROPRIATE CURX + LDCIF CURA(F),FA ;FA <- CURA +.ENDC + SETL + STF FA,FE ;SAVE ANGLE + JSR PC,SINDEG ;FA <- SIN (FA) +.IIF Z DDF, STCDF FA,SINA +.IIF NZ DDF, STCDF FA,SINA(F) ;SINA <- SINE OF ANGLE + LDD FE,FA ;GET ANGLE + JSR PC,COSDEG ;FA <- COS (FA) +.IIF Z DDF, STCDF FA,COSA +.IIF NZ DDF, STCDF FA,COSA(F) ;COSA <- COSINE OF ANGLE + ASL C ;CALCULATE DIRECTION + ASL C + MOV C,DIREC + RTS PC + + + + + + +;XYDIR +; CALL WITH D=DX, E=DY +; CALCULATE DIREC BASED ON DX AND DY +XYDIR: CLR A ;BUILD INDEX IN A + TST D ;IS DX POSITIVE + BGE XYDIR1 + NEG D ;ABSOLUTE VALUE OF DX + TST (A)+ ;PUT 2 INTO A +XYDIR1: TST E ;IS DY POSITIVE + BGE XYDIR2 + NEG E ;ABSOLUTE VALUE OF DY + INC A ;INCREMENT INDEX +XYDIR2: CMP D,E ;WILL GENERATE CARRY IF D,F ;NOW CLEAR MARKED BITS +DSGC1: MOV SNLIST,C ;POINTER TO SNAP LIST + BEQ DSGC8 ;OBVIOUSLY DOESN'T HAVE SNAPS + + JSR PC,.LOADC ;FIRST NODE OF LIST IS DUMMY +DSGC2: MOV C,E ;SAVE POINTER TO NODE +DSGC3: BIT #7777,A ;LEAVE ADDRESS ONLY + BEQ DSGC4 ;END OF LIST + MOV A,C ;POINTER TO NEXT NODE + JSR PC,.LOADC + ADD F,PC ;CHOOSE BETWEEN FREEING AND CLEARING + +;TRY TO FREE THE SNAP +DSGCF1: TST -(B) ;WAS SNAP MARKED? (B POINTS TO REF COUNT) + BNE DSGC2 ;EITHER DISPLAYED OR MARKED + +;NOT MARKED, AND NOT DISPLAYED ANYWHERE!! +;FREE THIS SNAP + JSR PC,.FREE ;CLEAN UP SNLIST + MOV E,C ;POINTER TO PREVIOUS NODE OF SNLIST + JSR PC,.STP1 ;STORE A AS TOP WORD OF PREVIOUS NODE + MOV B,D ;POINTER TO SNAP DCODE + JSR PC,DYFREE + BR DSGC3 + +DSGC6: BIC #100000,-(B) ;CLEAR MARKED BIT + BR DSGC3 + +;ADDS HACK +; COMPRESS ADDX'S AND ADDY'S STARTING AT LOCATION IN A +; AND GOING TO LOCATION IN B. (DOESN'T STORE WORD AT LOC IN B) +ADDSHK: MOV A,C ;C IS NEXT LOC TO STORE INTO. +ADHK0: CLR -(SP) ;FLAG. (NOT IN MIDDLE OF ADD'S) +ADHK1: CMP A,B ;ARE WE DONE? + BHIS ADFIN ;YES + MOV (A)+,D ;NEXT WORD + CMP D,#ADDY + BLO ADNOT ;NOT AN ADD + TST (SP) ;IN MIDDLE OF ADD'S ALREADY ? + BNE ADPHS1 ;YES + CLR E ;NO. THIS IS FIRST ADD + CLR F + INC (SP) ;SET FLAG +ADPHS1: CMP D,#ADDX ;THE BIGGER ADD COMMAND + BHIS ADPHSX +;IT IS AN ADDY + ADD D,F ;ADD THE DELTA-Y INTO F + BR ADHK1 ;LOOP BACK +ADPHSX: ADD D,E ;ADD THE DELTA-X INTO E + BR ADHK1 + +ADNOT: TST (SP) + BEQ ADHK2 ;NOT END OF ADD'S + JSR PC,ADPHSF ;JUST ENDED ADDS. + CLR (SP) +ADHK2: MOV D,(C)+ ;STORE THIS WORD + BR ADHK1 + +ADFIN: TST (SP)+ ;ALL WORDS PICKED UP + BEQ ADHK3 + JSR PC,ADPHSF ;BUT FIRST FINISH ADDS +ADHK3: RTS PC + +;ADD PHASE FINISHED. STORE ADDX E, ADDY F. +ADPHSF: BIC #176000,E + BIC #176000,F + BEQ ADPF1 ;DELTA-Y = 0 + BIS #ADDY,F + MOV F,(C)+ ;STORE ADDY +ADPF1: TST E + BEQ ADPF9 ;DELTA-X = 0 + BIS #ADDX,E + MOV E,(C)+ ;STORE ADDX +ADPF9: RTS PC + + +;MKDC +; CALLED BY LOGO GARBAGE COLLECTOR DURING MARKING PHASE +; CALLED WITH B POINTING TO SNAP NODE +MKDC: TST SNLIST ;CALLED TO KILL THE DISPLAY? + BEQ MKDC.K ;YES + BIT #7777,B + BEQ DSGC9 ;EMPTY SNAP +;MARK THE SNAP + PUSH A + SPUSH B + JSR PC,.LOAD ;POINT B TO NODE CONTAINING SNAP ADDR + TST B + BEQ MKDC1 + JSR PC,.LOAD ;B_SNAP ADDRESS + BIS #100000,-(B) ;MARK REF COUNTER +MKDC1: SPOP B ;RESTORE A AND B + SPOP A + RTS PC + +;CALLED BY KILLDISPLAY +;TURN SNAP INTO EMPTY SNAP +MKDC.K: SPUSH A + SPUSH B + SPUSH C + MOV B,C ;POINTER TO DCODE NODE + CLR A + JSR PC,.STP2 + JMP RETC + + + +;HERE START THE LINE AND TURTLE DRAWING PROGRAMS + +;DR.LIN +; DRAW A LINE. D=DX, E=DY, OR VICE VERSA. +; THE DIRECTION CODE FOR THE LINE IS IN DIREC +DR.LIN: CMP DIREC,ODIREC + BEQ 1$ + CLR DFBCNT +1$: JSR PC,DR.STUP ;SET A=CON, B=AC. + SPUSH D + ADD STT,D ;D = HOW MANY MORE WORDS IN DLIST + CMP D,DYB ;COMPARE TO DY BOTTOM + BLO DR.L1 ;THERE'S ROOM + JSR PC,.GCOLL ;TRY TO FREE SOME STORAGE + SPOP D ;TRY TO FIT LINE AGAIN + ADD STT,D + CMP D,DYB + BLO DR.L2 ;THERE'S ROOM! + ERROR+TML ;TOO MANY LINES + +;OKAY, THERE WAS ROOM FOR THE LINE +DR.L1: TST (SP)+ ;WE HAD PUSHED D UP ABOVE +DR.L2: MOV D,STT ;SET STT TO NEW STATIC TOP + MOV PUSHJT,(D) ;PUT PUSHJ TURTLE AT TOP + JSR PC,DR.ASC ;ASSEMBLE THE DISPLAY CODE + MOV DIREC,ODIREC + RTS PC ;RETURN + + +;DRAW THE TURTLE +DR.TUR: PUSH DIREC + SPUSH DFBCNT + MOV #TURSIZ,C ;TURTLE SIZE +.IFZ FPPF + CLR B + JSR PC,MULCOS ;E,,F _ SIZE * COSA + ROL F + ADC E ;ROUND + MOV E,D + JSR PC,MULSIN ;E,,F _ SIZE * SINA + ROL F + ADC E ;ROUNFD +.IFF + SETI + LDCIF C,FA + SETL +.IIF NZ DDF, LDCFD DSINA,FB +.IIF Z DDF, LDCFD SINA,FB + MULF FA,FB + ADDF #40000,FB ;ROUND +.IIF NZ DDF, LDCFD DCOSA,FC +.IIF Z DDF, LDCFD COSA,FC + MULF FA,FC + ADDF #40000,FC + SETI + STCFI FB,E + STCFI FC,D + SETL +.ENDC + + SPUSH D + SPUSH D + SUB E,2(SP) ;NOW SIZE * (COSA - SINA) IS ON STACK + ADD E,(SP) ;NOW SIZE * (COSA + SINA) IS ON STACK + + MOV TUB,TUT ;TUT WILL BE POINTER TO TOP OF TURTLE DLIST SO FAR +;FALLS THROUGH + ;FALLS IN + +;SIDE 1 + ADD #20,DIREC ;SIDE 1 IS 2*45 DEGREES LEFT OF CURRENT DIRECTION + JSR PC,DR.TSD ;DRAW THE SIDE + +;SIDE 2 + SUB #30,DIREC ;SIDE 2 IS 3*45 DEGREES RIGHT OF SIDE 1 + MOV (SP)+,D ;DX IS SIZE * (COSA + SINA) + MOV (SP)+,E ;DY IS SIZE * (COSA - SINA) + JSR PC,DR.TSD ;DRAW THE SIDE + +;SIDE 3 HAS THE SAME INCREMENTS AS SIDE 2. +;JUST THE DIRECTION IS DIFFERENT + MOV DIREC,B + SUB #20,B ;SIDE 3 IS 2*45 DEGREES RIGHT + BIC #177707,B ;LEAVE ONLY THE 3 BITS + SWAB B ;PUT THE DIREC BITS IN TOP BYTE + MOV TUT,C ;POINTS TO WORD ABOVE LAST ONE OF TURTLE DLIST + MOV C,A + SUB D,C ;SINCE D POINTS TO BOTTOM WORD OF SIDE 2 + ;C-D IS NUMBER OF BYTES IN SIDE 2'S DLIST + ASR C ;C/2 = NUMBER OF WORDS +DR.TS3: MOV (D)+,E ;NEXT WORD OF SIDE 2'S DLIST + BIC #34000,E ;CLEAR THE DIRECTION BITS THEREIN + BIS B,E ;AND SET THEM FROM THE NEW DIREC IN B + MOV E,(A)+ ;STORE IN DLIST + DEC C ;NUMBER OF WORDS IN SIDE 2'S DLIST + BGT DR.TS3 ;THERE ARE MORE WORDS + +;SIDE 4 IS IDENTICAL TO SIDE 1 +;FURTHERMORE, SIDE 1 IS MADE UP OF ONLY ONE WORD + MOV @TUB,(A)+ ;PUT THE FIRST WORD OF TURTLE INTO TOP WORD + MOV #DSTOP!DPOP,(A) + +;RESTORE DIREC, THEN RETURN + SPOP DFBCNT + POP DIREC + RTS PC + + +;DRAW TURTLE SIDE +; DRAW ONE SIDE OF THE TURTLE +; DIREC CONTAINS THE DIRECTION +; TUT POINTS TO TOP OF TURTLE DISPLAY LIST SO FAR +; C,D = + OR - DX OR DY +DR.TSD: BIC #177707,DIREC ;BITS MAY HAVE BEEN SET BY THE SUBTRACTING + CLR DFBCNT + JSR PC,DR.STUP + ADD TUT,D ;D = NEW TOP OF TURTLE + MOV D,TUT + JMP DR.ASC ;ACTUALLY CREAT THE DISPLAY LIST + + +;SET UP CON AND AC +; CALL WITH D,E = + OR - DX OR DY +; PASSES ON A=FRACTION: MIN (DX/DY,DY/DX) +; B=ACCUMULATED FRACTION PART SIDEWAYS OF MAIN DIRECT. +; STARTS AT 1/2 +DR.STUP: TST D + BGE DR.TE ;TEST E + NEG D ;MAKE D POSITIVE +;MAKE SURE E IS POSITIVE +DR.TE: TST E + BGE DR.BIG ;NEXT WE'LL SEE WHICH IS BIGGER + NEG E ;MAKE D POSITIVE + +;WHICH IS BIGGER +DR.BIG: CLR B ;CLEAR LOW WORD OF WHICHEVER NUMBER + CMP D,E + BGT DR.DBG ;D IS BIGGER + BEQ DR.EQ ;THEY ARE THE SAME SIZE + +;OTHERWISE, E IS BIGGER + ASL E ;SO EAE WON'T OVERFLOW WITH A 16 BIT QUOTIENT + MOV D,A ;DIVIDE D,,0 BY E + DIV E,A + MOV E,F ;WHICHEVER IS BIGGER IS THE NUMBER OF INCS + BR DR.SC4 + +;THEY ARE THE SAME SIZE +DR.EQ: MOV #-1,A ;SET CON = .777... + MOV E,F ;NUMBER OF INCS + BR DR.SC5 + +;D IS BIGGER +DR.DBG: ASL D + MOV E,A ;DIVIDE E,,0 BY D + DIV D,A + MOV D,F ;NUMBER OF INCS + +;NOW PICK UP THE QUOTIENT +DR.SC4: ASL A ;MAKE QUOTIENT 16 BITS + ASR F ;SINCE WE DOUBLED IT ABOVE + +;NOW SET AC = .1000 = 1/2 IN THIS REPRESENTATION +DR.SC5: MOV #100000,B + ;FALLS IN! + +;CALCULATE THE NEW END POINT OF THE DLIST +; RETURNS A AND B AS ABOVE +; C = BIT-POSITION OF LAST BIT OF NEW CODE +; (GENERATED BACKWARDS--STORE FROM HERE BACK) +; D = NUMBER OF MORE WORDS IN DLIST +; (WILL BECOME ADDR OF LAST NEW WORD + 2) +; E = TOP BYTE OF INCR INSTRUCTION, SWAPPED +; F = # NEW INCREMENTS +DR.NEP: CLR C ;CLEAR BIT-POSITION + MOV F,E ;GET # OF INCREMENTS + SUB DFBCNT,E ;LESS # LEFT OVER + MOV E,D + ASH #-3,D ;DIVIDE BY 8 + ASL D + BIC #177770,E ;REMAINDER IS # BITS IN LAST WORD + BEQ DR.NE2 ;IF 0 THEN = 8 IN PREVIOUS WORD + + MOV #8.,DFBCNT ;ELSE FREE BITS = 8 - # USED + SUB E,DFBCNT + ADD #2,D ;ADD ONE-WORD FUDGE FACTOR IN THIS CASE + SPUSH E + SEC +DR.NE1: RORB C ;SHIFT FIRST-BIT IN OR RIGHT ONE BIT + DEC E ;SHIFT IT RIGHT (REMAINDER) PLACES + BNE DR.NE1 + SPOP E + BR DR.NE3 + +;REMAINDER WAS 0: LAST WORD GETS FILLED UP +DR.NE2: INC C ;LAST BIT IS LAST IN WORD + CLR DFBCNT ;NO FREE BITS + +DR.NE3: ADD #DINC_-8,E ;PUT IN "INCREMENT" CODE + ADD DIREC,E ;ADD IN THE DIRECTION + RTS PC + + +;ACTUALLY ASSEMBLE THE NEW DISPLAY LIST +; CALL WITH A=SIDEWAYS/FORWARD, B=1/2 (ACCUM SIDEWAYS), +; C=FIRST BIT POS., D=POINTER TO FIRST WORD TO STORE OF DLIST +; E=TOP HALF OF THE INC MODE INSTRUCTION, F=NUMBER OF INCS +DR.ASC: SWAB E ;STUFF IN E WAS IN WRONG HALF +DR.AS0: ADD A,B ;CON+AC + BCC DR.AS1 + ADD C,E ;CARRY, SO PUT A 1 INTO DCODE +DR.AS1: DEC F ;NUMBER OF INCS + BLE DR.ALW ;THIS WAS THE LAST WORD + CLC + ROLB C ;SHIFT BYCNT + BCC DR.AS0 ;CONTINUE WITH THIS WORD + +;THIS WORD DONE + JSR PC,DR.SH + MOV E,-(D) ;STORE IN DLIST + BIC #3777,E ;0 THE COUNT AND BOTTOM BYTE + MOV #1,C ;RESET BYCNT + BR DR.AS0 + +;ALL THAT'S LEFT TO DO IS STORE THE BOTTOM WORD OF NEW DLIST +DR.ALW: MOV -(D),B ;GET WORD TO HOOK + CLR A ;SET UP BIT TO HOOK FROM + SEC ; " +DR.LW1: ROL A ; " OR NEXT BIT TO HOOK FROM + CLC + ROLB C ;NEXT BIT TO HOOK INTO + BCS DR.LW2 ;DONE HOOKING + BIT A,B ;GET BIT + BEQ DR.LWX + ADD C,E ;STORE IT +DR.LWX: CLC ;SET UP FOR ROL A + BR DR.LW1 + +DR.LW2: JSR PC,DR.SH ;SHOVE TO RIGHT END OF WORD + MOV E,(D) ;STORE LAST WORD + RTS PC + +;SHIFT CODE RIGHT 8 MINUS COUNT TIMES + +DR.SH: PUSH E + SWAB E ;GET COUNT OF USED BITS +DR.SH1: BIC #177770,E ;ISOLATE COUNT + BEQ DR.SH2 ;DONE + INC E ;COUNT UP; DONE AT 8 (OR 0) + CLC + RORB (SP) ;MAKE ANOTHER FREE BIT AT LEFT + BR DR.SH1 +DR.SH2: POP E + RTS PC + +.ENDC +.ENDC + + +.IFNZ TVS +.SBTTL TV TURTLE ROUTINES +;;;;;;;;;;;;;;;;;;;; +;TV TURTLE ROUTINTES +;;;;;;;;;;;;;;;;;;;; + +;THESE ROUTINES ARE USED TO PROCESS DISPLAY GRAPHICS FOR TVS. +;THE ROUTINES ARE IN MANY CASES BASED ON, AND TRY TO FOLLOW THE +;WORK OF HENRY LIEBERMAN WITH HIS TVRTLE ROUTINES FOR LLOGO. + +FAKTVR: ;Move real TV register to Fake locations + ;for debugging. Symbols FAKADR, FAKWIN, FAKINC, ... + MOV COLORA, FAKCLA + MOV COLORD, FAKCLD + MOV TVINCR, FAKINCR + MOV TVSEL, FAKSEL + MOV TVRADR, FAKADR + MOV TVWDCN, FAKWDC + MOV TVSHR, FAKSHR + MOV TVMSK, FAKMSK + MOV TVRWIN, FAKWIN + MOV TVCNSO, FAKCNS +FAKEND: RTS PC + + + +TVSTRT: JSR PC,TVINIT ;CREATE DISPLAY +TVSTR1: MOV TVBOT,B ;EVERYTHING BELOW DISPLAY AREA CAN BE ECHO AREA + JSR PC,CRECHO ;CREATE THE ECHO AREA IN SCREEN + JSR PC,TVCS ;CLEAR SCREEN, RESET TURTLE + LDFPS #40300 ;RESET THE FLOATING POINT PROCESSOR + SEZ + RTS PC + + +;CREATE A DISPLAY CAPABILITY AND INITIALIZE VARIABLES +TVINIT: JSR PC, IORMODE +CTVINIT: + BIC #,DFLAGS + CLR DPENP ;START WITH PENDOWN + BIS #DISPF!TVF,DFLAGS ;WE ARE CONTROLING DISPLAY AND IT IS A TV DISPLAY + BIS #DISPF,DIVOWN ;WE OWN A DISPLAY + MOV #DORBEG,A +TVINI1: CLR (A)+ ;CLEAR OUT THIS AREA + CMP A,#DOREND + BLO TVINI1 + MOV #2.,TVTOP ;TOP OF DISPLAY AREA IS TV LINE 2 + MOV #302.,TVBOT ;BOTTOM OF DISPLAY AREA IS TV LINE 302 + MOV #273.,TVLEFT ;LEFT SIDE OF DISPLAY AREA IS LINE 138 + MOV #573.,TVRIGHT ;RIGHT SIDE OF DISPLAY AREA IS LINE 438 + MOV #301.,TVSIZY ;Y SIZE IS 300. + MOV #301.,TVSIZX ;X SIZE IS 300. + MOV #152.,TVCENY ;Y CENTER IS 152. + MOV #423.,TVCENX ;X CENTER IS 288. + MOV #301.,TVMIN ;SIZE OF TV PICTURE + MOV #400.,TRMIN ;TURTLE PICTURE SIZE + CLR TRCENX ;TURTLE PICTURE CENTER X + CLR TRCENY ;TURTLE PICTURE CENTER Y + MOV TVCENX,TVX + MOV TVCENY,TVY ;THE DRAWER SHOULD GO INTO THE CENTER OF BOX +; SAVE +; BIS #.TVDSS*400,(P) ;SET THE DRAWER TO THE RIGHT PLACE +; $INVOK + SETF + SETI ;THE FOLLOWING STUFF IS IN SHORT INTEGER AND FLOAT MODE + LDCIF #1.,FA + STF FA,TRSCLX ;STORE 1 AS THE TURTLE SCALE + STF FA,TRSCLY ;LIKEWISE + REINIT: SETF + SETI + LDCIF TRMIN,FA ;TURTLE SIZE X(Y)=TURTLE SCASLE FACTOR X(Y) + LDF TRSCLX,FB + MULF FA,FB ;MULTIPLIED BY THE TURTLE MINIMUM DIMENSION + STF FB,TRSIZX + LDF TRSCLY,FC + MULF FA,FC + STF FC,TRSIZY + LDCIF #-2,FD ;TURTLE LEFT BOUNDRY=TURTLE SIZE X/-2 + DIVF FD,FB + STF FB,TRLEFT + NEGF FB ;TURTLE RIGHT BOUNDRY= -TURTLE LEFT BOUNDRY + STF FB,TRRIGH + DIVF FD,FC ;TURTLE BOTTOM BOUNDRY=TURTLE SIZE Y/-2 + STF FC,TRBOT + NEGF FC ;TURTLE TOP BOUNDRY= -TURTLE BOTTOM BOUNDRY + STF FC,TRTOP + LDCIF TVMIN,FB + SUBF FLTTOL,FB + SUBF FLTTOL,FB + DIVF FB,FA + STF FA,TRPRTV ;TURTLE PER TV = TRMIN / (TVMIN - FLOAT TOLERANCE * 2) + LDCIF #15.,FB + MULF FA,FB + STF FB,TRFRAD + LDCIF #10.,FB + MULF FA,FB + STF FB,TRSRAD + RTS PC + + +;Color TV initializations. Follows Lisp TVRTLE and BEE;CLRTST programs. + +.IFNZ COLOR + +FLSBUF: ;Delete capabilities to display buffers in DSCAP table. + MOV #PIXMAX, C ;Size of capability table for loop index. + MOV #DSCAP, B ;Index into capability table. +FLBLUP: MOV (B), A + CLR (B)+ + JSR PC, DELCP + SOB C, FLBLUP + RTS PC + +COLORINIT: ;Color initialization. + JSR PC, FLSBUF ;FLUSH ALL BUFFERS + JSR PC, G1NARG ;Argument is number of buffers [bits per point]. + TST B + BLT 1$ + CMP #4,B + BGE 2$ +1$: ERROR+WTA +2$: + CLR A +GRABUF: ;Magic SITS system call to grab a buffer. + SAVE <#-1, #40377, #.DSCAP*400+0> + .INVOK + BNE GOTBUF + ADD #6,P ;FLUSH ARGS TO FAILED CALL + BR GOTBU1 ;TERMINATE PREMATURELY +GOTBUF: + REST + TST (A)+ ;Stuff capabilities and associated buffer numbers + SOB B, GRABUF ;in tables. + +GOTBU1: MOV A,B + ASR B ;NUMBER OF BUFFERS WE REALLY GOT + MOV DSCAP, A ;Pass along capability to one of the color buffers. + JSR PC, TVRMAP ;Do the system call mapping in TV registers. + MOV B, NCBITS ;Stow this in NCBITS. + MOV #1, A + ASH B, A ;(SETQ PALETTE-SIZE (LSH 1 NCBITS)) + MOV A, PALSIZ + CLR PENNUM + MOV A, ERANUM ;(SETQ :ERASERNUMBER (1- PALETTE-SIZE)) + DEC ERANUM + ASR A + MOV A, NCSIGB ;High order color bit. + RTS PC + +CRESET: JSR PC,INITCR ;Initialize video switch and console register. + BIS #TVOFLO,TVINCR ;Mask to handle overlow correctly in TVINCR. + JSR PC, SETMODE ;Choose SET drawmode [others don't make sense in color]. + MOV #-1., WINDATA ;Always write bits on [SETMODE clears WINDATA]. + BR CLRWRT ;Turn on color write mode. + + +INITCR: CLR C ;Initialize console register and video switch. + MOV NCBITS, B ;Do the following loop NCBITS times, for each buffer. +ICRLUP: MOV DSNUM (C), D ;Retrieve buffer number from DSNUM table. + MOV D, TVSEL ;Select that buffer. + MOV CRMC (C), TVCNSO ;Move magic constant from table to console register. + MOV C, E + ASH #<-1.+8.>, E ;Construct word with buffer number in low order byte + ADD E, D ;and word index in buffer table in high order byte, + ADD VSWMC, D ;and magic constant added for video switch. + MOV D, VIDSW + TST (C)+ + SOB B, ICRLUP + + MOV #6,A ;THERE ARE SIX BITS IN THE COLOR MAP + SUB NCBITS,A ;NUMBER OF BUFFERS WE SEEM TO HAVE + ASH #7,C ;FOR NON-EX BUFFERS + ADD #30_8,C ;MUST SWITCH TO NOTHINGNESS + ADD #17,C ;I THINK THIS IS IT?? +INITC2: MOV C,VIDSW ;NOTHING FOR YOU + ADD #1_8,C ;NEXT + SOB A,INITC2 ;THERE BETTER BE AT LEAST ONE COLOR BIT TO SWITCH TO NON-EX!! + RTS PC + + +;FULSCREEN: ;For color, the default TV size should be whole screen. +; MOV #450., TVBOT ;Change TV, TURTLESIZE default to whole screen. +; MOV #2., TVLEFT +; MOV #574., TVRIGHT +; MOV #574., TVSIZX +; MOV #449., TVSIZY +; MOV #289., TVCENX +; MOV #226., TVCENY +; MOV TVCENX, TVX +; MOV TVCENY, TVY +; MOV #449., TVMIN +; MOV #1000., TRMIN +; SETF +; SETI +; LDCIF #1000., FA +; LDCIF #448., FB +; DIVF FB, FA +; STF FA, TRSCLX +; JMP REINIT ;Redo TURTLESIZE to keep variables consistent. + + +.CLRINIT: ;.COLORINIT user primitive + JSR PC, COLORINIT ;Additional initialization for color. + SAVE B ;SAVE NUMBER OF BUFFERS WE GOT + JSR PC, CTVINIT ;Do standard initializations for all TV's. + JSR PC,CRESET ;DO EXTRA STUFF FOR COLOR + BIS #COLORF, DFLAGS ;Set flag indicating use of color display. +CINIWON: + LDFPS #40300 ;Reset floating point processor [whatever that means]. + REST B + JMP R1NARG + +;WBLOCK: ;[WRITE-TV-BLOCK] uses block mode of +; TST C ;hardware to write lots of words at once. +; BEQ WBLEND ;Arguments: ADDRESS, CONTENTS, ITERATIONS, STEP. +; BIC #TVINC, TVINCR ;(WRITE-CONTROL-FIELD TVINCR-ADDRESS STEP TVINC-MASK) +; BIS D, TVINCR +; MOV A, TVRADR ;(WRITE-TV-WORD ADDRESS CONTENTS) +; MOV B, TVRWIN +; DEC C +; TST C ;(COND ((ZEROP (DECREMENT ITERATIONS)) ...) +; BEQ WBLINC +; NEG C +; MOV C, TVWDCN ;(WRITE-TV-WORD-COUNT (- ITERATIONS)) +;WBWAIT: +; BIT #TVWDCM, TVWDCN ;(DO NIL ((ZEROP (READ-TV-WORD-COUNT)))) +; BNE WBWAIT +;WBLINC: +; BIC #TVINC, TVINCR ;(WRITE-CONTROL-FIELD TVINCR-ADDRESS 0. TVINC-MASK) +;WBLEND: RTS PC + + +CLRWRT: BIS #COLORW, DFLAGS ;Sets color write mode [COLOR-WRITE]. + BIS #TVCLRW, TVINCR ;Set color write bit in increment register. + BR RESELC ;Reselect color. + +NOCLRW: BIC #COLORW, DFLAGS ;Turns off color write mode [NO-COLOR-WRITE]. + BIC #TVCLRW, TVINCR ;Falls thru to RESELECT-COLOR. + +RESELC: BIT #ERASEF, DFLAGS ;Reselects the proper color in the palette + BNE SELERA ;according to pen or eraser state [RESELECT-COLOR]. + ;Falls through to SELECT-PEN. + +SELPEN: MOV PENNUM, A ;Select the pen color. + BR SELCOL + +SELERA: MOV ERANUM, A ;Select the eraser color. + ;Falls thru to SELECT-COLOR. +SELCOL: ;Selects a current color from the palette or, +SELBUF: ;Selects one of the TV buffers [same code]. + ;[SELECT-COLOR, SELECT-TV-BUFFER] + BIC #TVRCNS, TVSEL + BIS A, TVSEL ;Write the color or buffer number into the + SEZ + RTS PC ;console number field in the console select + ;register. + +.COLOR: ;User primitive to select a color in color map. + JSR PC, G1NARG ;Returns fixpoint number in B. + MOV B, A + MOV A, PENNUM + JMP SELCOL + + +;[WRITE-COLOR-MAP] Writes a new color into the color map. +;Arguments: COLOR-MAP-SLOT, RED, GREEN, BLUE intensities. +; +;WCMAP: SAVE A ;Save slot number. +; MOV B, COLORD +; BIS #CLRRED, A ;IOR slot number with red. +; MOV A, COLORA ;Color written when address register written. +; MOV C, COLORD +; MOV (P), A ;Restore slot from stack, without popping. +; BIS #CLRGREEN, A ;Or with green, +; MOV A, COLORA +; MOV D, COLORD +; REST A ;Pop off slot number. +; BIS #CLRBLUE, A ;And similarly for blue. +; MOV A, COLORA +; RTS PC +; +; +;.WRIMAP: ;.WRITEMAP user primitive to write into color map. +; JSR PC, G1NARG ;Takes 4 args: slot number, RED, GREEN, BLUE +; SAVE B +; JSR PC, G1NARG +; SAVE B +; JSR PC, G1NARG +; SAVE B +; JSR PC, G1NARG ;Remove 4 args from stack, put then in A, B, C, D +; MOV B, D +; REST +; JSR PC, WCMAP ;The routine that does the work. +; SEZ +; RTS PC +; + +.WRIRED: + JSR PC, G2NARG ;Get two integer args, return them in A and B. + MOV #CLRRED, C ;It's the red we want to write. + BR WRIMAP + +.WRIGREEN: + JSR PC, G2NARG + MOV #CLRGREEN, C + BR WRIMAP + +.WRIBLUE: + JSR PC, G2NARG + MOV #CLRBLUE, C + ;Falls thru to WRIMAP. + +WRIMAP: ;Writes a color into color map. Args: slot number + ;in B, beam intensity in A, mask for which beam in C. + BIS C, B ;IOR slot number with mask for RED, GREEN, or BLUE. + MOV A, COLORD ;Write into color data before color address. + MOV B, COLORA + SEZ + RTS PC + + +.REAPAL: ;.READPALETTE user function. + JSR PC, G1NARG + ASL B ;Double for number of bytes from start of palette. + SPUSHS PALETTE (B) ;Indexes supplied arg into the palette. + CLZ + RTS PC + +.WRIPAL: ;.WRITEPALETTE user function. + MOV @S, B ;Atom from S stack to B [don't pop to leave GC protect] + MOV #ATOM, A ;Convert to type ATOM, type check, etc. + JSR PC, CONVERT ;Atom returns in B. + SAVE B + ADD #2, S ;Remove atom from S stack. + JSR PC, G1NARG ;Index to write into in B + ASL B ;Multiply by 2 to get byte address. + REST PALETTE (B) ;Move atom into position in palette indexed by A. + SEZ + RTS PC + +.ENDC ;End of color conditional assembly section. + + +XORMODE: + MOV #TVXOR, A + BR WINMODE +IORMODE: + MOV #TVIOR, A +WINMODE: + MOV #-1., WINDATA ;XOR, IOR draw with bits on. + BR DRAWMODE +SETMODE: ;SET mode for eraser draws with bits off. + MOV #TVSET, A ;In color, however, in SETMODE always but bits on. + CLR WINDATA +DRAWMODE: ;Sets mode for writing into screen memory. + BIC #TVRWMD, TVSEL ;Choose from: TVIOR, TVSET, TVXOR. + BIS A, TVSEL + RTS PC + + + + + + +;TVCHK CHECKS IF MY TTY IS A TV. IT CLEARS Z IF IT IS, SETS Z OTHERWISE. +;ALSO SETS THE TV FLAG IN DFLAGS. +TVCHK: SAVE <,,TYOCP> + BIS #.TTTYP*400,(P) ;GET FLAGS FROM TTY TABLE + $INVOK + BIT #200,(P)+ ;BIT 200 IS THE TV FLAG + BEQ TVCHK1 ;IS NOT A TV + BIS #TVF,DFLAGS ;YES IT IS! + SAVE <#-1,TYOCP> + BIS #140000,(P) + SAVE #0+.DSCAP*400 ;0 IS CREATE CAPABILITY + $INVOK + REST ;CREATE THE DISPLAY CAP + MOV DISCAP, A ;Falls thru to TVRMAP. + +TVRMAP: ;Map in TV control registers. + SAVE <#0, #4, A, #.CRWRT!1> + MOVB #DISPG+10, 3 (P) + $MAP ;Magic SITS system call to access TV control registers. + SAVE <,,#.TVSAV*400> + MOVB A, (P) + $INVOK ;Magic SITS system call enabling saving of TV registers. +TVCHK1: RTS PC + + +;CREATE AN ECHO AREA WITH SIZE BASED ON FONT. EXPECTS THE TV LINE OF THE TOP +;OF THE ECHO AREA IN B + +CRECHO: +.IFNZ COLOR + BIT #COLORF, DFLAGS + BEQ CREBW + RTS PC +.ENDC +CREBW: + SAVE ;Save TV registers over system calls. + SAVE <,#.TSCRL,TYOCP> + BIS #.TTBS2*400,(P) ;GO INTO SCROLL MODE FOR NOW + $INVOK + SAVE <,,TYOCP> + BIS #.TVCL*400,(P) ;SO WE CAN RESET THE SCREEN + $INVOK ;AND DO A REAL CLEAR + SAVE <,#.TSCRL,TYOCP> + TST B ;DOES HE REALLY WANT AN ECHO AREA? + BNE CRECH1 + BIS #.TTBS2*400,(P) ;NO, SET THE SCROLL MODE BIT + BR CRECH2 +CRECH1: BIS #.TTBC2*400,(P) ;YES, CLEAR THE SCROLL MODE BIT TO USE WRAP MODE +CRECH2: $INVOK + SAVE <,,TYOCP> + BIS #.TVRFN*400,(P) ;READ THE NUMBER OF TV LINES PER CHAR LINE + $INVOK ;AND THE WIDTH OF CHAR IN BITS + REST + CLR A ;FOR THE DIVIDE + DIV TVHIGH,A ;DIVIDE BY NUBER OF TV LINES PER CHAR LINE + TST B ;ANY REMAINDER? + BEQ 1$ ;COUNT IT AS ONE MORE LINE + INC A +1$: SAVE <,A,TYOCP> + BIS #<.TVOFF+.PRWRT>*400,(P) ;SET THE OFFSET TO SET THE ECHO AREA + $INVOK ;THIS WILL CLEAR SCREEN AND THUS SET CURSOR + MUL TVHIGH,A + MOV B,TVSIZE ;THE DISPLAY AREA HAS THIS MANY LINES + REST + RTS PC + +TVCS: SETF + SETI + LDCIF TRCENX,FA + STF FA,DCURX ;RESET DCURX + LDCIF TRCENY,FA + STF FA,DCURY ;RESET DCURY + CLR DCURA ;RESET DCURA + CLRF FA + STF FA,DSINA ;RESET DSINA + LDCIF #1,FA + STF FA,DCOSA ;RESET DCOSA + MOV TVCENX,TVX + MOV TVCENY,TVY ;SO THE DRAWER WILL GO BACK TO CENTER OF SCREEN +;FALL IN TO TVWC + + +TVWC: ;TV WIPECLEAN. +.IFNZ COLOR + BIT #COLORF, DFLAGS + BEQ WCBW +CTVWC: JSR PC, TVWCOL + BR WCDPAL +.ENDC +WCBW: JSR PC, TVWCBW +WCDPAL: JSR PC, CLEPAL + JMP DTVTUR +TVWC1: SEZ + RTS PC + + +.IFNZ COLOR +TVWCOL: ;Clear screen in color. [TV-CLEARSCREEN] WIPECLEAN + JSR PC, SELERA ;(SELECT-COLOR :ERASERNUMBER) + JSR PC, FILSCR +; JSR PC, SELPEN +; JSR PC, OUTLIN + JMP RESELC + +FILSCR: CLR TVMSK + CLR TVRADR + MOVB #1, TVINCR + MOV #TVRWIN, C + MOV WINDATA, A + MOV #WORLIN*453., B +FLSCLUP: + MOV A, (C) + SOB B, FLSCLUP + CLRB TVINCR + RTS PC + +;Block mode unreliable when switching processes. +;CTVWC: CLR A ;(WRITE-TV-BLOCK 0. -1. 16344. 1) +; MOV #-1., B +; MOV #16344., C +; MOV #1, D +; JSR PC, WBLOCK +; JMP RESELC ;(RESELECT-COLOR) + +.ENDC + +TVWCBW: SAVE + JSR PC, SETMODE ;To clear the screen in black and white, + JSR PC, FILDIS + JSR PC, IORMODE + JSR PC, OUTLIN + REST + RTS PC + +FILDIS: ;Fill display area bounded by TVTOP, BOT, LEFT, RIGHT. + MOV TVLEFT, A + MOV TVRIGHT, B + MOV TVTOP, C + MOV TVBOT, D ;Falls through to FILWIN. + + +FILWIN: ;Fills area bounded by A, B, C, D + MOVB #WORLIN, TVINCR ;Words written a line at a time. + SUB C, D + INC D ;Number of lines to be written in D. + MOV A, E + BIC #-<15.+1>, E + ASL E + MOV STARMSK (E), TVMSK ;Calculate starting mask. + MOV B, E + BIC #-<15.+1.>, E + ASL E + SAVE STOPMSK (E) ;Save stopping mask. + ASH #-4., A + ASH #-4., B ;Left and right in words. + MOV C, F + MUL #BYTLIN, F + MOV A, E + ASL E + ADD E, F ;Byte address in F. + MOV WINDATA, E + CMP A, B ;Starting and stopping words equal? + BNE FILMTOW + BIC (P)+, TVMSK ;And starting and stopping masks. + BR FILSTRIP +FILMTOW: ;Fill more than one word. + SUB A, B + DEC B ;Iteration counter for full word loop. + BEQ FILAST ;If zero, don't bother. + JSR PC, FILSTRIP ;Do the first partial word loop. + CLR TVMSK ;Prepare to write a full word. +FILWLUP: + JSR PC, FILSTRIP + SOB B, FILWLUP +FILAST: REST TVMSK ;Falls through to do last partial word strip. +FILSTRIP: ;Fills a vertical strip of the area. + MOV F, TVRADR ;#WORLIN in TVINCR, Address in F, Number of lines in D + MOV D, A ;WINDATA in E, mask in TVMSK, clobbers A. +FILUP: MOV E, TVRWIN + SOB A, FILUP + TST (F)+ ;F now points to first word in next column. + RTS PC + + +CLEPAL: ;[CLEAR-PALETTE] + MOV #PALETTE, A + MOV ERANUM, B + MOV ERANUM, C + SUB PENNUM, C ;(SETQ C (- :ERASERNUMBER :PENNUMBER)) +PALUP: CMP B, C ;If we're currently working on pencolor slot, skip it. + BEQ NILPAL + MOV #LIST, (A) ;Fill slots 0 thru :ERASERNUMBER-1 with NILs +NILPAL: TST (A)+ + SOB B, PALUP ;except for slot :PENNUMBER. + RTS PC + +OUTLINE: ;Draw box outlineing display area. + SAVE TVSIZX + INC (P) + SAVE TVSIZY + INC (P) + SAVE TVLEFT + DEC (P) + MOV TVTOP, A ;Remember, silly DRAW routine wants arguments + DEC A + MOV (P), B ;Y start, X start, delta Y, delta X. + CLR C + MOV 4 (P), D ;(1+ TVSIZX) + JSR PC, DRAW ;Top line. + MOV TVBOT, A + INC A + MOV (P), B + CLR C + MOV 4 (P), D ;(1+ TVSIZX) + JSR PC, DRAW ;Bottom line. + MOV TVTOP, A + MOV (P), B ;(1+ TVLEFT) + MOV 2 (P), C ;(1+ TVSIZY) + CLR D + JSR PC, DRAW ;Left side. + MOV TVTOP, A + MOV TVRIGHT, B + INC B + MOV 2 (P), C + CLR D + ADD #6, P ;Pop three temporaries off stack. + JMP DRAW ;Right side. + +;TVWCBW: ;Black and white version. +; SAVE +; BIS #.TVDSS*400,(P) ;SET THE TV DRAWER TO TOP LEFT OF DISPLAY +; $INVOK +; SAVE +; BIS #.TVDSC*400,(P) ;CLEAR THE AREA OF DISPLAY +; $INVOK ;THIS LEAVES DRAWER AT BOTTOM RIGHT +; SAVE +; BIS #.TVDSS*400,(P) ;SET THE CURSOR TO TOP LEFT +; $INVOK +; SAVE ;X WIDTH OF SCREEN, NO DELTA Y +; BIS #.TVDSI*400,(P) ;DRAW THE TOP LINE +; $INVOK +; SAVE <#0,TVSIZY,DISCAP> ;NO DELTA X, SCREEN HEIGHT IS DELTA Y +; BIS #.TVDSI*400,(P) ;DRAW THE RIGHT SIDE +; $INVOK +; SAVE TVSIZX ;X WIDTH OF SCREEN +; NEG (P) ;TO GO BACK +; SAVE <#0,DISCAP> ;NO DELTA Y +; BIS #.TVDSI*400,(P) ;DRAW THE BOTTOM LINE +; $INVOK +; SAVE <#0,TVSIZY> ;NO DELTA X, THE SCREEN HEIGHT AS DELTA Y +; NEG (P) ;TO GO UP THE SCREEN +; SAVE DISCAP +; BIS #.TVDSI*400,(P) ;DRAW THE LEFT SIDE +; $INVOK +; +; SAVE +; BIS #.TVDSS*400,(P) ;RESET THE DRAWER TO ITS OLD POSITION +; $INVOK + + + + ;TURTLESIZE ROUTINE +TRSIZE: JSR PC,TVTEST ;ON TV? + JSR PC,G1NARG + MOV B,TRMIN + JSR PC,REINIT + SEZ + RTS PC + + ;TVSIZE ROUTINE +RESIZE: JSR PC,TVTEST + JSR PC,DCHK + MOV D,A + CMP A,#2. ;CHECK THE NUMBER OF ARGS. + BEQ SIZ2ARG + BGT SIZWNA + CMP A,#1. ;POPOFF NUMBER OF ARGS. + BEQ SIZ1ARG ;IF ONE ARG. +SIZWNA: ERROR+WNA ;ERROR-WRONG NUMBER OF ARGS. +SIZ2ARG: + JSR PC,G2NARG ;GET TWO ARGS. X IN B Y IN +; JSR PC,CHSIZE ;CHECK SIZE OF Y ARG. (IN A) + + CMP B, #TVXSMN ;Check reasonableness of TVSIZE args. + BLT XSIZER + CMP B, #TVXSMX + BGT XSIZER + CMP A, #TVYSMN + BLT YSIZER + CMP A, #TVYSMX + BLE OKSIZE +YSIZER: MOV A,B +XSIZER: JSR PC,R1NARG + ERROR + WTA +OKSIZE: EXCH A, B ;Exch A, B. Rest of code wants this. Change this? + + MOV B,-(SP) ;STORE B + +; MOV A,B +; JSR PC,CHSIZE ;CHECK SIZE OF X ARG. NOW COPIED IN B + + MOV (SP)+,B ;RESTORE B + CMP A,B ;WHICH IS SMALLER AND PUT IT INTO + BGT SIZMIN ;TVMIN + MOV A,TVMIN + BR SIZRST + SIZ1ARG: + JSR PC,G1NARG ;GET 1 ARG. (X DIMENSION=Y DIMENSION) + MOV B,A ;COPY DIMENSION +; JSR PC,CHSIZE ;CHECK SIZE OF ARG. + CMP A, #TVYSMN + BLT YSIZER + CMP A, #TVYSMX + BGT YSIZER +SIZMIN: MOV B,TVMIN +SIZRST: MOV A,TVSIZX ;RESET PARAMETERS + MOV B,TVSIZY + MOV B,TVBOT + ADD TVTOP,TVBOT ;NEW TV BOTTOM OF DISPLAY AREA + MOV TVRIGH,TVLEFT ;NEW TVLEFT=TVRIGHT-TVSIZE X + SUB A,TVLEFT + SETI + SETF + LDCIF A,FA + LDCIF B,FB ;STORE FOR USE LATER A,B + ASR A ;TV CENTER X=(TVSIZE X/2)+TVLEFT + ADD TVLEFT,A + MOV A,TVCENX + ASR B ;LIKEWISE FOR Y + ADD TVTOP,B + MOV B,TVCENY + LDCIF TVMIN,FC ;TURTLE SCALE FACTOR X!Y= + DIVF FC,FA ;TV SIZE X!Y/TVMIN + STF FA,TRSCLX + DIVF FC,FB + STF FB,TRSCLY + JSR PC,REINIT + MOV TVBOT,B + JSR PC,CRECHO + JSR PC,TVCS + SEZ + RTS PC + + + +TVSHOW: BIC #HIDETF, DFLAGS ;The turtle now not hidden. + JMP DTVTUR +TVSHO1: SEZ + RTS PC + +TVHIDE: JSR PC, ETVTUR ;Remove the turtle cursor from the screen. + BIS #HIDETF, DFLAGS ;Mark the turtle as being hidden. +TVHID1: SEZ + RTS PC + + +SEETURTLE: ;Returns TRUE if in SHOWTURTLE mode, FALSE in HIDETURTLE + BIT #HIDETF, DFLAGS + BNE SEERTF ;HIDETF bit in DFLAGS indicates whether turtle is hidden + JMP RTTRUE +SEERTF: JMP RTFALSE + + + + +.IFNZ TVS +DTVTUR: ;[DRAW-TURTLE] + BIT #HIDETF, DFLAGS ;If turtle hidden, forget about it. + BNE DTUREND +DTURST: + BIT #CLIPF, DFLAGS ;In CLIP mode, if HERE is out of bounds, forget it. + BEQ DTNCLP + LDF DCURX, FA + LDF DCURY, FB + JSR PC, CLPVIS + TST A + BNE DTUREND +DTNCLP: +.IFNZ COLOR + BIT #COLORF, DFLAGS + BNE DTVCLR +.ENDC + SAVE + JSR PC, XORMODE ;and draw triangle in XOR mode. + BR DTRIAN + +.IFNZ COLOR +DTVCLR: JSR PC, SELPEN ;In color, (SELECT-COLOR :PENNUMBER) +.ENDC + +DTRIAN: JSR PC, TRIANG +.IFNZ COLOR + BIT #COLORF, DFLAGS + BEQ DTURBW ;In color, restore selected color. + JMP RESELC +.ENDC + +DTURBW: REST + ;In black and white, restore drawmode and flags. +DTUREN: SEZ ;Frequently want to return no-value at this point. + RTS PC + +ETVTUR: ;[ERASE-TURTLE] + BIT #HIDETF, DFLAGS + BNE ETUREND +ETURST: + BIT #CLIPF, DFLAGS ;In CLIP mode, if HERE is out of bounds, forget it. + BEQ ETNCLP + LDF DCURX, FA + LDF DCURY, FB + JSR PC, CLPVIS + TST A + BNE ETUREND +ETNCLP: + +.IFNZ COLOR + BIT #COLORF, DFLAGS + BNE ETVCLR +.ENDC + SAVE + JSR PC, XORMODE + BR ETRIAN + +.IFNZ COLOR +ETVCLR: JSR PC, SELERA +.ENDC + +ETRIAN: JSR PC, TRIANG + +.IFNZ COLOR + BIT #COLORF, DFLAGS + BEQ ETURBW + JMP RESELC +.ENDC + +ETURBW: REST +ETUREN: RTS PC +.ENDC + + +TRIANG: SETF + SETI ;THE FOLLOWING STUFF IS DONE IN SHORT, FLOAT MODE + LDF DCURX,FA + LDF DCURY,FB ;LOAD UP CURRENT X AND Y + LDF TRFRAD,FC ;TURTLE FRONT RADIUS + STF FC,FD ;COPY THE RADIUS + MULF DSINA,FC ;FONT LINE X IS FRONT RADIUS * SIN A + MULF DCOSA,FD ;FONT LINE Y IS FRONT RADIUS * COS A + ADDF DCURX,FC + ADDF DCURY,FD ;MAKE THIS POINT LESS RELATIVE + JSR PC,WRPVEC ;DRAW AS WRAP VECTOR + STF FC,-(P) ;SAVE THIS POINT + STF FD,-(P) + STF FC,FA ;BECOMES THE FROM X + STF FD,FB ;BECOMES THE FROM Y + LDF TRSRAD,FC ;TURTLE SIDE RADIUS + STF FC,-(P) ;SAVE IT ON STACK + LDF DSINA,FD + MULF SIN120,FD + STF FD,-(P) + LDF DCOSA,FD + MULF COS120,FD + ADDF (P)+,FD ;Y = SIN A * SIN 120 + COS A * COS 120 + MULF (P),FD ;Y = TURTLE SIDE RADIUS * Y + LDF DCOSA,FC + MULF SIN120,FC + STF FC,-(P) + LDF DSINA,FC + MULF COS120,FC + SUBF (P)+,FC ;X = SIN A * COS 120 - COS A * SIN 120 + MULF (P),FC ;X = TURTLE SIDE RADIUS * X + ADDF DCURX,FC + ADDF DCURY,FD ;MAKE LESS RELATIVE + JSR PC,WRPVEC ;DRAW THE RIGHT SIDE OF TURTLE + STF FC,FA ;BECOMES THE FROM X + STF FD,FB ;BECOMES THE FROM Y + LDF DSINA,FD + MULF SIN240,FD + STF FD,-(P) + LDF DCOSA,FD + MULF COS240,FD + ADDF (P)+,FD ;Y = COS A * COS 240 + SIN A * SIN 240 + MULF (P),FD ;Y = TURTLE SIDE RADIUS * Y + LDF DCOSA,FC + MULF SIN240,FC + STF FC,-(P) + LDF DSINA,FC + MULF COS240,FC + SUBF (P)+,FC ;X = SIN A * COS 240 - COS A * SIN 240 + MULF (P)+,FC ;X = TURTLE SIDE RADIUS * X + ADDF DCURX,FC + ADDF DCURY,FD ;MAKE LESS RELATIVE + JSR PC,WRPVEC ;DRAW THE BOTTOM OF TURTLE + STF FC,FA ;BECOMES THE FROM X + STF FD,FB ;BECOMES THE FROM Y + LDF (P)+,FD ;Y FROM FRONT LINE + LDF (P)+,FC ;X FROM FRONT LINE + JSR PC,WRPVEC ;DRAW THE LEFT SIDE OF THE TURTLE + RTS PC + + +;VECTOR DRAW LINES ON THE SCREEN. IT EXPECTS: +;FROM X IN FA +;FROM Y IN FB +;TO X IN FC +;TO Y IN FD + +VECTOR: SETF ;ALL THE FOLLOWING STUFF IS IN FLOAT MODE + SETI ;AND IN SHORT INTEGER MODE + STF FC, -(P) ;Save TO point over vector drawing. + STF FD, -(P) + BIT #,DFLAGS ;CHECK THE BOUNDS, IF WRAPPING OR + BNE 2$ ;CLIPPING, NO CHECKING IS NEEDED + JSR PC,TRBOUN +2$: BIT #HIDETF,DFLAGS ;ARE WE SHOWING THE TURTLE? + BNE VECTO1 ;NO + JSR F,FACSAV ;SAVE THE REGISTERS + JSR PC, ETURST ;THIS CAUSES IT TO GO AWAY + JSR F,FACRES ;RESTORE THE REGISTERS +VECTO1: BIT #PENUF, DFLAGS ;Check state of pen, etc., decide whether to draw line. + BEQ VECTDR ;Pendown, draw the line. + BIT #, DFLAGS + BEQ VECTO3 ;Pen, eraser, xor up, skip drawing the line. +VECTDR: BIT #WRAPF,DFLAGS ;ARE WE IN WRAP MODE? + BNE VECTO2 ;YES + + BIT #CLIPF,DFLAGS ;CLIP MODE? + BEQ VECTO5 ;NO + JSR PC, CLPVEC + BR VECTO3 +VECTO5: JSR PC,BNDVEC ;NO DRAW A BOUNDED VECTOR + BR VECTO3 +VECTO2: JSR PC,WRPVEC ;YES DRAW VECTORS WITH WRAPAROUND +VECTO3: LDF (P)+, FD + LDF (P)+, FC + STF FC,DCURX + STF FD,DCURY ;THE NEW CURRENT POSITION + JMP DTVTUR ;PUT THE TURTLE IN ITS NEW HOME +VECTO4: SEZ + RTS PC + +TVBOUN: CMP C,TVLEFT + BLT OUTOFB + CMP C,TVRIGH + BGT OUTOFB + CMP D,TVTOP + BLT OUTOFB + CMP D,TVBOT + BGT OUTOFB + RTS PC +TRBOUN: ;CHECKS BOUNDRIES FOR TVRTLE + CMPF TRLEFT,FC + CFCC + BGT 1$ + CMPF TRRIGH,FC + CFCC + BLT 1$ + CMPF TRTOP,FD + CFCC + BLT 1$ + CMPF TRBOT,FD + CFCC + BGT 1$ + RTS PC +1$: +OUTOFB: ERROR+OOB + +;Old "clipping" code. To be flushed. +OCLIP: CMPF TRLEFT,FC ;THIS CODE WHEN IN CLIP MODE + CFCC ;CHECKS THE BOUNDS OF THE + BLE 3$ ;VECTOR AND IF THE VECTOR RUNS + LDF TRLEFT,FC ;OUT OF BOUNDS IT IS CLIPPED BY +3$: CMPF TRRIGH,FC ;PLACING THE TURTLE COORDINATE OF + CFCC ;THAT EDGE INTO THE APPROPRIATE + BGE 4$ ;PARAMETER + LDF TRRIGH,FC +4$: CMPF TRTOP,FD + CFCC + BGE 5$ + LDF TRTOP,FD +5$: CMPF TRBOT,FD + CFCC + BLE VECTO5 + LDF TRBOT,FD + BR VECTO5 + + + +;Code for vectors in CLIP mode. Follows clip algorithm in Newman & Sproull. + +;Following routine returns a VISIBILITY number in A 0-15 indicating +;whether point is outside display area in X and/or Y. Coordinates of point in FA +;and FB. + +CLPVIS: ;[CLIP-VISIBILITY] + CLR A + CMPF TRLEFT, FA ;Compare with left edge, outside if X less. + CFCC + BLE CPVSRT + INC A + BR CPVSBT +CPVSRT: CMPF TRRIGHT, FA ;Compare against right, outside if X greater. + CFCC + BGE CPVSBT + TST (A)+ ;Increment A by 2. +CPVSBT: CMPF TRBOT, FB ;Outside if Y < bottom edge in turtle coords. + CFCC + BLE CPVSTP + ADD #4., A + RTS PC +CPVSTP: CMPF TRTOP, FB ;Outside if Y > top edge. + CFCC + BGE CPVSEND + ADD #8., A +CPVSEND: + RTS PC + + +;Vector clipping routine. FROM-X in FA, FROM-Y in FB, TO-X in FC, TO-Y in FD. + + +CLPVEC: ;[CLIP-VECTOR] + STF FA, -(P) + STF FB, -(P) ;Save FROM point. + JSR PC, CLPVIS ;Compute visibility of FROM point. + SAVE A + LDF FC, FA + LDF FD, FB + JSR PC, CLPVIS ;Compute visibility of TO point. + MOV A, B + REST A + LDF (P)+, FB + LDF (P)+, FA ;FROM-VISIBILITY in A, TO-VISIBILITY in B. +CLPVS: ;[CLIP-VECTOR-VISIBILITY] + MOV A, C + ADD B, C ;If both points are inside display area + BNE CLPOUT ;hand off to BOUNDED-VECTOR. + JMP BNDVEC +CLPOUT: + BIT A, B ;If both points are outside X or both + BEQ CLPDRW ;outside Y whole vector is invisible. + RTS PC +CLPDRW: + TST A ;Exchange points if necessary so that + BNE CLPNSW ;TO point is visible. + STF FA, -(P) + LDF FC, FA + LDF (P)+, FC + STF FB, -(P) + LDF FD, FB + LDF (P)+, FD + EXCH A, B +CLPNSW: + BIT #1., A ;Push towards left edge. + BEQ CLPRT + STF FB, -(P) + STF FA, -(P) + SUBF FC, FA + SUBF FD, FB + DIVF FA, FB + LDF TRLEFT, FA + SUBF (P)+, FA + MULF FA, FB + ADDF (P)+, FB + LDF TRLEFT, FA +CLPRT: BIT #2., A ;Push toward right edge. + BEQ CLPTP + STF FB, -(P) + STF FA, -(P) + SUBF FC, FA + SUBF FD, FB + DIVF FA, FB + LDF TRRIGHT, FA + SUBF (P)+, FA + MULF FA, FB + ADDF (P)+, FB + LDF TRRIGHT, FA +;FALLS THROUGH + ;FALLS IN +CLPTP: BIT #4., A ;Push toward top. + BEQ CLPBT + STF FA, -(P) + STF FB, -(P) + SUBF FC, FA + SUBF FD, FB + DIVF FB, FA + LDF TRBOT, FB + SUBF (P)+, FB + MULF FB, FA + ADDF (P)+, FA + LDF TRBOT, FB +CLPBT: BIT #8., A ;Push toward bottom. + BEQ CLPNVS + STF FA, -(P) + STF FB, -(P) + SUBF FC, FA + SUBF FD, FB + DIVF FB, FA + LDF TRTOP, FB + SUBF (P)+, FB + MULF FB, FA + ADDF (P)+, FA + LDF TRTOP, FB +CLPNVS: JSR PC, CLPVIS ;Recompute visibility for FROM point. + BR CLPVS + + + +;WRPVEC DRAWS VECTORS WITH WRAP AROUND BY SPLITTING THE LINES IN THE VARIOUS +;SCREENS THAT IT CROSSES, AND CALLING BNDVEC TO ACTUALLY DRAW THE LINES ON +;EACH OF THE VIRTUAL SCREENS. THE SCREEN SPLITTING IS DONE BY CHOPPING OFF +;PIECES OF THE LINE AND CALLING WRPVEC RECURSIVELY. THIS PROCEDURE IS +;ESSENTIALLY A HAND COMPILATION OF THE PROCEEDURE WRAP-VECTOR IN HENRY +;LIEBERMAN'S TVRTLE, A PART OF LISP LOGO + +WRPVEC: JSR F,FACSAV ;SAVE ALL THE REGISTERS + STF FA,FE + SUBF TRLEFT,FA + DIVF TRSIZX,FA + TSTF FA + CFCC + BGE 1$ + SUBF #40200,FA ;-0.1 SHOULD TRUNCATE TO -1 NOT 0 +1$: STCFI FA,A ;FROM-SCREEN-X=(FROM-X - TR-PIC-LEFT)/ TR-PICT-SIZE + LDF FE,FA + STF FC,FE + SUBF TRLEFT,FC + DIVF TRSIZX,FC + TSTF FC + CFCC + BGE 2$ + SUBF #40200,FC +2$: STCFI FC,C ;TO-SCREEN-X=(TO-X - TR-PICT-LEFT)/ TR-PICT-SIZE + LDF FE,FC + CMP A,C ;FROM-SCREEN-X = TO-SCREEN-X ? + BEQ WRPVE2 ;YES + STF FC,-(P) + STF FD,-(P) ;GET SOME REGISTERS + SUBF FA,FC ;CHANGE-X = TO-X - FROM-X + SUBF FB,FD ;CHANGE-Y = TO-Y - FROM-Y + TSTF FC + CFCC + BGE WRPVE1 + MOV #-1,E + BR .+6 +WRPVE1: MOV #1,E ;IF CHANGE-X >= 0 THEN SIGN-X = 1 ELSE SIGN-X = -1 + DIVF FC,FD + STF FD,FE ;TAN-HEADING = CHANGE-Y / CHANGE-X + LDCIF A,FC ;FROM-SCREEN-X + MULF TRSIZX,FC + ADDF TRLEFT,FC ;TO-EDGE-X=TR-PIC-SIZE-X*FROM-SCREEN-X + TR-PICT-LEFT + TST E + BLT 1$ ;IF SIGN-X >= 0 + ADDF TRSIZX,FC ; THEN ADD TURTLE-PICT-SIZE-X TO TO-EDGE-X +1$: LDF FC,FD + SUBF FA,FD + MULF FE,FD + ADDF FB,FD ;TO-EDGE-Y=(TO-EDGE-X - FROM-X)*TAN-HEADING + FROM-Y + STF FC,FE + LDCIF E,FC + ADDF FPC0.1,FC + STF FC,FF ;BACK-OFF-EDGE = SIGN X + 0.1 + LDF FE,FC + SUBF FF,FC + JSR PC,WRPVEC ;(WRAP-VECTOR FROM-X + ; FROM-Y + ; TO-EDGE-X - BACK-OFF-EDGE + ; TO-EDGE-Y) + LDF FE,FA + ADDF FF,FA + LDF FD,FB + LDF (P)+,FD + LDF (P)+,FC + JSR PC,WRPVEC ;(WRAP-VECTOR TO-EDGE-X + BACK-OFF-EDGE + ; TO-EDGE-Y + ; TO-X + ; TO-Y) + JSR F,FACRES + RTS PC + +WRPVE2: STF FB,FE + SUBF TRBOT,FB + DIVF TRSIZY,FB + TSTF FB + CFCC + BGE 1$ + SUBF #40200,FB ;TO MAKE -0.1 TRUNCATE TO -1 +1$: STCFI FB,B ;FROM-SCREEN-Y=(FROM-Y - TR-PICT-BOTTOM) / TR-SIZE-Y + LDF FE,FB + STF FD,FE + SUBF TRBOT,FD + DIVF TRSIZY,FD + TSTF FD + CFCC + BGE 2$ + SUBF #40200,FD ;TO MAKE -0.1 TRUNCATE TO -1 +2$: STCFI FD,D ;TO-SCREEN-Y=(TO-Y - TR-PICT-BOTTOM) / TR-SIZE-Y + LDF FE,FD + CMP B,D ;FROM-SCREEN-Y = TO-SCREEN-Y ? + + BEQ WRPVE4 ;YES + STF FC,-(P) + STF FD,-(P) ;GET SOME REGISTERS + SUBF FA,FC ;CHANGE-X = TO-X - FROM-X + SUBF FB,FD ;CHANGE-Y = TO-Y - FROM-Y + TSTF FD + CFCC + BGE WRPVE3 ;IF CHANGE-Y < 0 + MOV #-1,E ; THEN SIGN-Y = -1 + BR .+6 +WRPVE3: MOV #1,E ; ELSE SIGN-Y = 1 + DIVF FD,FC + STF FC,FE ;TAN-HEADING = CHANGE-X / CHANGE-Y + LDCIF B,FD + MULF TRSIZY,FD + ADDF TRBOT,FD ;TO-EDGE-Y=FROM-SCREEN-Y * TR-PICT-SIZE-Y + TR-PICT-BOT + TST E + BLT .+6 ;IF SIGN-Y >= 0 + ADDF TRSIZY,FD ; THEN TO-EDGE-Y = TO-EDGE-Y + TR-SIZE-Y + LDF FD,FC + SUBF FB,FC + MULF FE,FC + ADDF FA,FC ;TO-EDGE-X=TAN-HEADING*(TO-EDGE-Y - FROM-Y)+FROM-X + STF FD,FE + LDCIF E,FD + MULF FPC0.1,FD + STF FD,FF ;BACK-OFF-EDGE = SIGN-Y * 0.1 + LDF FE,FD + SUBF FF,FD + JSR PC,WRPVEC ;(WRAP-VECTOR FROM-X + ; FROM-Y + ; TO-EDGE-X + ; TO-EDGE-Y - BACK-OFF-EDGE) + LDF FC,FA + LDF FE,FB + ADDF FF,FB + LDF (P)+,FD + LDF (P)+,FC + JSR PC,WRPVEC ;(WRAP-VECTOR TO-EDGE-X + ; TO-EDGE-Y + BACK-OFF-EDGE + ; TO-X + ; TO-Y) + JSR F,FACRES + RTS PC + +;NOW BOTH FROM X, TO X AND FROM Y, TO Y ARE ALL ON THE SAME SCREEN. +;WE MUST CONVERT THAT SCREEN TO OVERLAY THE CENTER SCREEN BY A +;MODULO TYPE OPERATION. + +WRPVE4: STF FB,-(P) + SUBF TRLEFT,FA + DIVF TRSIZX,FA + MODF #40200,FA ;MUL BY 1, FRACTION IN FA, INTEGER IN FB + TSTF FA + CFCC + BGE 1$ + ADDF #40200,FA ;SO NEGATIVE VALUES WRAP PROPERLY +1$: MULF TRSIZX,FA + ADDF TRLEFT,FA ;SHIFT FROM X TO THIS SCREEN + LDF (P)+,FB + SUBF TRBOT,FB + DIVF TRSIZY,FB + MODF #40200,FB ;MUL BY 1 TO GET FRACTION IN FB + TSTF FB + CFCC + BGE 2$ + ADDF #40200,FB ;SO NEGATIVE VALUES WRAP PROPERLY +2$: MULF TRSIZY,FB + ADDF TRBOT,FB ;SHIFT FROM Y TO THIS SCREEN + STF FD,-(P) + SUBF TRLEFT,FC + DIVF TRSIZX,FC + MODF #40200,FC ;#1 IN FLOATING + TSTF FC + CFCC + BGE 3$ + ADDF #40200,FC ;SO NEGATIVE VALUES WRAP PROPERLY +3$: MULF TRSIZX,FC + ADDF TRLEFT,FC ;SHIFT TO X TO THIS SCREEN + LDF (P)+,FD + SUBF TRBOT,FD + DIVF TRSIZY,FD + MODF #40200,FD ;#1 IN FLOATING + TSTF FD + CFCC + BGE 4$ + ADDF #40200,FD ;SO NEGATIVE VALUES WRAP PROPERLY +4$: MULF TRSIZY,FD + ADDF TRBOT,FD ;SHIFT TO Y TO THIS SCREEN + JSR PC,BNDVEC ;(BOUNDED-VECTOR FROM-X FROM-Y TO-X TO-Y) + JSR F,FACRES + RTS PC + +;BNDVEC IS THE EQUIVALENT OF HENRY'S BOUNDED-VECTOR. IT IS USED TO DRAW A +;LINE ON THE SCREEN WITHOUT CONSIDERING WRAP AROUND. THIS PROGRAM ASSUMES +;THAT THE LINE IS WITHIN BOUNDS. + +BNDVEC: JSR F,FACSAV ;SAVE THE REGISTERS + JSR PC,TVSCAL ;CONVERT FROM TURTLE COORDINATES TO TV COORDS +; JSR PC,ROUND ;ROUND FA AND FB TO NEAREST INTEGER + STCFI FA, B + STCFI FB, A + LDF FC,FA + LDF FD,FB + JSR PC,TVSCAL ;CONVERT FROM TURTLE COORDINATES TO TV COORDS +; JSR PC,ROUND ;ROUND TO NEAREST INTEGER + STCFI FA, D + STCFI FB, C +; CMP A,TVX ;SEE IF WE SHOULD MOVE THE DRAWER +; BNE BNDVE1 ;YES +; CMP B,TVY +; BEQ BNDVE2 +BNDVE1: +; SAVE +; BIS #.TVDSS*400,(P) ;SET THE DRAWER TO FROM-X AND FROM-Y +; $INVOK +BNDVE2: MOV D, TVX + MOV C, TVY ;TO-X AND TO-Y BECOME CURRENT TV DRAWER COORDS + SUB A,C + SUB B,D ;TO GET DELTA-X AND DELTA-Y +; SAVE +; BISB DRAWMD,1(P) ;SET THE MODE OF THE LINE +; $INVOK + + JSR PC, DRAW ;Draw the line. + + JSR F,FACRES ;RESTORE THE REGISTERS + RTS PC + + ;LINE DRAWER FOR TV'S +;EXPECTS: +;A - STARTING Y POSITION 0-473 +;B - STARTING X POSITION 0-575 +;C - DELTA Y +;D - DELTA X + +DRAW: + TST D ;DO WE HAVE A NEGATIVE DELTA X + BGE DRAW5 ;NO + ADD C,A + ADD D,B + NEG C + NEG D ;REVERSE THE DIRECTION THE LINE IS DRAWN +DRAW5: JSR PC, ADRMSK ;GET THE BYTE ADDRESS IN B, X MOD 16 IN A + SAVE B ;THIS WILL GO INTO TVRADR + MOV A, E ;BIT MASK IN E. + TST C ;IS DELTA Y POSITIVE? + BGE DRAW4 ;YES + MOV #-BYTLINE, A ;THE Y STEP IS ONE LINE UP THE SCREEN + NEG C ;TO MAKE DELTA Y POSITIVE + BR .+6 +DRAW4: MOV #BYTLINE, A ;THE Y STEP IS ONE LINE DOWN THE SCREEN + CLR B ;THIS WILL BE FLAG FOR HORIZONTAL OR VERTICAL + CMP C,D ;IS DELTA Y GREATER THAN DELTA X + BGE DRAW1 ;YES + SAVE D ;SINCE D > C, D WILL BE DIVISOR + MOV C,D ;C WILL BE THE DIVIDEND + BR DRAW3 +DRAW1: SAVE C ;SINCE C > D, C WILL BE DIVISOR + TST (B)+ ;DRAW A VERTICAL LINE +DRAW3: CLR C ;FOR THE DIVIDE + ASHC #14.,C ;SO WE GET A FRACTIONAL RESULT + DIV (P),C ;GET A QUOTIENT IN C + MOV #40000,D ;ADD TO THIS NUMBER TO GET A CARRY + REST F ;THE NUMBER OF STEPS WE WILL MOVE + INC F ;SO WE SHOW THE INITIAL POINT + BIC #TVINC, TVINCR ;INCREMENT 0 + MOV (P), TVRADR ;Set up the address [on top of stack]. + REST ;Pop one remaining arg. + JMP @DRAWTB(B) ;DRAW EITHER A HORIZONTAL OR VERTICAL LINE + + + + +DRAWH: + MOV WINDATA, B +DRHLUP: + MOV E, TVMSK ;Complement of point mask in TVMSK. + MOV B, TVRWIN ;Write bits from B. + ADD C,D ;ADD INCREMENT UNTIL WE OVERFLOW TO NEGATIVE + BVC DRAWH1 + BIC #100000,D ;GO BACK TO A POSITIVE NUMBER + BIS #40000,D ;SO WE WILL OVERFLOW AT THE RIGHT PLACE + ADD A,TVRADR ;IF WE DID, THEN GO UP OR DOWN ONE LINE +DRAWH1: SEC ;IN CASE PREVIOUS OP CAUSES CARRY + ROR E ;SHIFT THE BIT RIGHT ONE POSITION + BCS DRAWH2 ;WE DID NOT OVERFLOW + ROR E ;MOVE CARRY INTO BIT 15 + ADD #2,TVRADR ;ADVANCE TO NEXT WORD +DRAWH2: SOB F,DRHLUP ;DRAW A MORE HORIZONTAL LINE + RTS PC + +DRAWV: + MOV WINDATA, B +DRVLUP: + MOV E, TVMSK + MOV B, TVRWIN + ADD C,D ;ADD INCREMENT UNTIL WE OVERFLOW + BVC DRAWV1 + BIC #100000,D ;GO BACK TO POSITIVE + BIS #40000,D ;SO WE WILL OVERFLOW AGAIN AT RIGHT PLACE + SEC + ROR E ;MOVE THE BIT RIGHT ONE POSITION + BCS DRAWV1 ;NO OVERFLOW + ROR E ;MOVE BIT FROM CARRY INTO BIT 15 + ADD #2,TVRADR ;NOW DOING THE NEXT WORD +DRAWV1: ADD A,TVRADR ;ADD THE Y INCREMENT TO THE TV ADDRESS + SOB F, DRVLUP ;LOOP UNTIL WE FINISH DRAWING THE LINE + RTS PC + +;GETADR USES THE Y POSITION IN A AND THE X POSITION IN B TO GIVE A BYTE ADDRESS +;IN B AND MASK TO THE APPROPRIATE BIT IN A. + +ADRMSK: JSR PC, GETADR + ASL A + MOV POIMSK (A), A + RTS PC + + +GETADR: SAVE C ;NEED A REGISTER + MOV B,C ;PUT X POSITION IN C + MUL #BYTLINE, A ;ADDRESS OF THE START OF THE LINE + MOV C,A ;PUT X BACK, THE HIGH ORDER OF MUL SHOULD BE ZERO + ASH #-4,C ;GET WORD FROM START OF LINE + ASL C ;BYTE + ADD C,B ;GET THE FINAL BYTE ADDRESS + BIC #177760,A ;GET X MOD 16 IN A + REST C + RTS PC + + + +;CONVERT FROM TURTLE COORDINATES TO TV COORDINATES +TVSCAL: SUBF TRLEFT,FA + DIVF TRPRTV,FA + STF FA,-(P) + LDCIF TVLEFT,FA + ADDF (P)+,FA ;X = (X - TR-PICTURE-LEFT)/TURTLE-PER-TV + TV-PICT-LEFT + SUBF TRBOT,FB + DIVF TRPRTV,FB ;THIS GIVES THE NUMBER OF TV STEPS FROM TOP OF DISPLAY + STF FB,-(P) ; AND SINCE TV LINES INCREASE DOWN THE SCREEN: + LDCIF TVBOT,FB + SUBF (P)+,FB ;Y = TV-PICT-BOTTOM - (Y - TR-PICT-BOTTOM)/TR-PER-TV +; RTS PC + JMP ROUND + +;TVHEAD IS USED TO SET THE TURTLE TO THE APPROPRIATE HEADING. +;EXPECTS THE NEW HEADING IN B +TVHEAD: JSR PC, ETVTUR ;Erase the turtle if it's being shown. +TVHEA2: MOV B,DCURA ;THIS BECOMES THE CURRENT ANGLE + SETI + SETD + LDCIF B,FA + STF FA,-(P) + JSR PC,SINDEG ;GET DSIN A + STCDF FA,DSINA + LDF (P)+,FA + JSR PC,COSDEG ;GET DCOS A + STCDF FA,DCOSA + JMP DTVTUR ;Show the turtle at its new location. +TVHEA1: SEZ + RTS PC + + + + +;Point hacking routines. + +POINT: + MOV D,A + JSR PC, PHACK ;Argument handling routine for POINT and POINTSTATE. + BIT #HIDETF, DFLAGS + BNE POIHT + SAVE + JSR PC, ETURST ;Erase the tutle if it's being shown. + REST +POIHT: MOV D, TVRADR ;Address comes back in D, bit mask in C + MOV C, TVMSK ;Mask register gets word with relevant bit off. + MOV WINDATA, TVRWIN ;which gets written into memory data register. + JMP DTVTUR + +POINTSTATE: + MOV D,A + JSR PC, PSHACK + BIT #HIDETF, DFLAGS + BNE PSHT + SAVE + JSR PC, ETURST + REST +PSHT: + BIT #COLORF, DFLAGS ;Color or black-and-white? + BNE PSCOLOR +PSBW: MOV D, TVRADR ;Test to see if point masked by C is on in word at D. + BIT C, TVRWIN + BEQ PSRTFALSE +PSRTTRUE: ;Return true. + JSR PC, DTVTUR + JMP RTTRUE +PSRTFALSE: + JSR PC, DTVTUR + JMP RTFALSE ;Return false. +PSCOLOR: ;Color version thereof. + JSR PC, RTVPN ;Find number corresponding to point. + CMP A, ERANUM ;Is the point on in the eraser color? + BEQ PSRTFALSE + JSR PC, DTVTUR + JMP RTTRUE + + +POINTCOLOR: ;Returns the color of a point. + MOV D,A + JSR PC, PSHACK + BIT #HIDETF, DFLAGS + BNE PCHT + SAVE + JSR PC, ETURST + REST +PCHT: + BIT #COLORF, DFLAGS ;As for POINT and POINTSTATE... + BNE PCLRC + MOV PENNUM, A +PCLRBW: MOV D, TVRADR + BIT C, TVRWIN ;In black and white, for compatibility, return + BNE PCLRN ;either PEN or ERASER color. + MOV ERANUM, A + BR PCLRN +PCLRC: JSR PC, RTVPN ;In color, get the point's color number from the screen. +PCLRN: ASL A + SPUSHS PALETTE (A) ;Index into palette to retrieve symbol for color. + JSR PC, DTVTUR + CLZ + RTS PC + + +RTVPN: ;[READ-TV-POINT-NUMBER, sort of] + JSR PC, NOCLRW ;Common routine for point hacking, takes address + MOV NCBITS, F ;of a word in D, Mask for a bit in C, reads the point + CLR B ;and returns number of point's color in A. Color write + MOV NCSIGB, E ;mode temporarily turned off. + MOV D, TVRADR ;Word index into address register. + MOV #DSNUM, D +RTVLUP: MOV (D)+, A ;Grab number of buffer from DSNUM table. + JSR PC, SELBUF ;Select buffer number in A [SELBUF doesn't clobber]. + BIT C, TVRWIN ;Read bit in that buffer. + BNE RTVEND ;Bit is complemented, remember. + ADD E, B ;Add to the point's total. +RTVEND: ASR E ;Shift bit one place to the right. + SOB F, RTVLUP + JSR PC, CLRWRT ;Needn't save B, CLRWRT doesn't clobber. + RTS PC + + + +PHACK: ;THIS IS A KLUDGE THAT DOES THE FIRST PART OF BOTH POINT AND POINTSTATE + JSR PC,TVDEF ;FA GETS TVX FOR ROUTINE FB GETS TVY AND CHECKS BOUNDS + STCFI FA, B ;ADRMSK takes X in B, Y in A, returns address of word + STCFI FB, A ;in B, mask to point in A. + JSR PC, ADRMSK + MOV A, C ;Shuffle registers [perhaps change this?]. + MOV B, D + RTS PC + +PSHACK: ;For POINT reading functions, return complemented mask. + JSR PC, PHACK + COM C + RTS PC + + + +TVARGE: ERROR+WNA +TVDEF: TST A + BEQ TVDEF1 ;ARGS NOT + CMP #2, A + BNE TVARGE + JSR PC, G2NARG ;GET ARGS, returns X in B, Y in A. + SETF + SETI + LDCIF A, FB + LDCIF B, FA + LDF FA, FC + LDF FB, FD + BR TVDEF2 +TVDEF1: SETF + SETI + LDF DCURX, FA + LDF DCURY, FB ;ARGS NOT SPECIFIED, use turtle's position. +TVDEF2: JSR PC, TRBOUN + JMP TVSCAL ;CONVERT TO TV COORDINATES + + + +;ROUTINES FOR SAVING AND RESTORING FLOATING POINT REGISTERS +FACSAV: PUSH E + SAVE + STF FA,-(P) + STF FB,-(P) + STF FC,-(P) + STF FD,-(P) + STF FA,FACTMP ;TEMPORARY LOCATION + LDF FE,FA + STF FA,-(P) + LDF FF,FA + STF FA,-(P) + LDF FACTMP,FA ;RESTORE FA + JMP (F) ;RETURN + +FACRES: TST (P)+ + LDF (P)+,FA + STF FA,FF + LDF (P)+,FA + STF FA,FE + LDF (P)+,FD + LDF (P)+,FC + LDF (P)+,FB + LDF (P)+,FA + REST + POP E + RTS F + + +.IFNZ DPM1 +MAKEWINDOW: ;FIRST DO ARGUMENT DECODING, DEFAULT PARAMETERS, BOUNDRY CHECK + JSR PC,G2ARG ;FB_W SIZE X + SETI ;FA GETS W SIZE Y + SETF + STF FA,FE ;COPY + STF FB,FF ;SIZE + STF FA,FB ;AND SWITCH ARGS + LDF FF,FA + LDCIF #2.,FC + DIVF FC,FA + DIVF FC,FB + LDF DCURX,FC ;PRESENTLY W CENTER IS HOME + LDF DCURY,FD +; STCFI FC,C +; STCFI FD,A + SUBF FA ,FC ;W RT EDGE=W CENTER X-SIZE/2 + SUBF FB,FD ;LIKEWISE FOR BOTTOM + JSR PC,TRBOUN ;CHECK BOUNDS + LDF FC,FA ;STORE THE EDGES + LDF FD,FB + ADDF FF,FC ;CALC. OTHER EDGES + ADDF FE,FD + JSR PC,TRBOUN ;CHECK BOUNDS + JSR PC,TVSCAL ;CONVERT [FA,FB] TO TV COORDINATES +; JSR PC,ROUND ;ROUND OFF + STCFI FA,E + STCFI FB,D + LDF FC,FA ;THE SAME FOR OTHER EDGES + LDF FD,FB + JSR PC,TVSCAL +; JSR PC,ROUND + STCFI FA,B + STCFI FB,F + LDF DCURX,FA + LDF DCURY,FB + JSR PC,TVSCAL +; JSR PC,ROUND + STCFI FA,C + STCFI FB,A + SAVE ;PUSH TOP, LEFT,W CENTER Y,WCENTER X + +;FALL THROUGH + ;FALLS IN + ;NOW CALCULATE DIMENSIONS OF WINDOW AND LENGTH OF ARRAY NEEDED +;EMULATE THE ARGUMENT SET UP OF DEFAR SO AS TO BE ABLE TO JUMP INTO +;THE MIDDLE AND HAVE IT BIND AND ALLOCATE THE ARRAY + + SUB E,B ;#OF BITS (W LT EDGE-W RT EDGE) + CLR A ;SET UP DIVIDE + DIV #16.,A + MOV B,-(P) ;PUSH LEFTOVER (REMAINDER) + BEQ 1$ + INC A ;X DIM.=QUOITIENT+1 UNLESS NO LEFTOVER +1$: SUB F,D ;Y DIM.=W BOTTOM-W TOP + MOV D,F + MUL A,D + ;LENGTH OF ARRAY NOW IN D + SAVE + SAVE <#MAKEW1,F,A,#2> ;PUSH RETURN ADDRESS,Y DIM,X DIM,ARRAY TYPE + JMP WALLOC ;DO ARRAY BINDING AND ALLOCATION + + ;SET UP THE ARRAY HEADER WITH NECASSARY WINDOW INFORMATION + +MAKEW1: MOV TMPBLK,F ;F GETS A POINTER TO THE ARRAY + ADD #4,F ;F NOW POINTS TO WORD ALLOCATED FOR THE # DIM + MOV #2+LNUM,(F)+ ;FILL HEADER- #OF DIM AND ARRAY TYPE + MOV (P)+,(F)+ ;XDIM + MOV (P)+,(F)+ ;YDIM + MOV (P)+,(F)+ ;SINCE THERE IS NO Z DIM I CAN STORE THE LEFTOVER IN IT + REST ;POP W CENX,W CENY + MOV A,(F)+ ;PUT W CENX + MOV E,(F)+ ;AND W CENY INTO ARRAY HEADER + MOV (P),B + SUB A,B ;DISTANCE FROM W CENTER TO LEFT EDGE + MOV B,(F)+ ;PUT IT INTO HEADER + SPOP B + MOV (P),D + SUB E,D ;DISTANCE FROM W CENTER TO TOP EDGE + MOV D,(F)+ ;PUT IT IN HEADER + SPOP D ;HEADER NOW FULL,STACK EMPTY, + + +;SET UP FOR TRANSFER. THE TRANSFER IS DONE BY TWO NESTED DO LOOPS +;THE INNER LOOP READS AND SHIFTS AND STORES ONE LINE OF THE WINDOW EXCEPT +;FOR THE LAST WORD OF THE LINE WHICH NEEDS A MASK FOR THE LAST #LEFTOVER +;BITS. WHEN THE INNER LOOP IS FINISHED IT IS REINITIALIZED BY ADDING THE +;NUMBER OF WORDS ACROSS THE SCREEN MINUS THE #OF WORDS IN THE X DIM OF THE W +;TO THE POINTER INTO DISPLAY MEMORY AND PUTTING #OF WORDS IN THE X DIM OF THE W +;MINUS 1 INTO THE COUNTING REGISTER FOR THE INNER LOOP. THE OUTER LOOP DOES THIS +;THE NUMBER OF LINES IN THE WINDOW (Y DIM) + +;;Replace mask-creating code with masks from STARMSK, STOPMSK. + CLR A ;MAKE MASK + COM A ;OF THE #LEFTOVER + ASH -10.(F),A ;LOW ORDER BITS + COM A + SPUSH A ;PUSH MASK +; MOV -14.(F),C ;C GETS XDIM +; SPUSH C ;PUSH INIT. VALUE OF COUNTER FOR INLUP + SPUSH -14.(F) + CLR A + DIV #16.,A + MUL #36.,D ;CALCULATE THE FIRST WORD OF WINDOW + ADD A,D + ASL D ;CONVERT TO BYTES +; ADD #DISAD,D + SPUSH D + SPUSH B + MOV -12.(F),C ;COUNTER FOR OUTER LOOP GETS YDIM + ;NOW DO THE TRANSFER AND SHIFT FROM WINDOW TO THE ARRAY + +; JSR PC,TVMON +; MOVB #1., TVINCR ;Increment address a word at a time. +; MOV D, TVRADR + CLRB TVINCR +OUTLUP: MOV 4(P),E ;(RE)SET COUNT1 + +INLUP: MOV D,TVRADR + MOV TVRWIN, A ;Pick up next two words of display memory. + ADD #2.,D + MOV D,TVRADR + MOV TVRWIN,B ;Address increments a word at a time. +; MOV (D)+,B ;READ NEXT +; MOV (D),A ;TWO WORD OF DISPLAY MEMORY + + + ASHC (P),A ;SHIFT + COM A ;STORE THE WINDOW IN COMPLEMENTED FORM + MOV A,(F)+ ;PUT THE WORD INTO THE WINDOW ARRAY + SOB E,INLUP ;ITERATE + BIS 6.(P),-2(F) ;MASK THE EXTRANEOUS BITS + + ADD #BYTLINE, 2(P) ;Point to word in next line. +; MOV 2(P), TVRADR ;Less 2 because address incremented each read. + MOV 2(P),D + + SOB C,OUTLUP ;ITERATE + ADD #8.,P ;CLEAR STACK + SEZ + RTS PC + + +SHWERR: ERROR+WNA + ;FIRST DECODE ARGS + + +HIDEWINDOW: + SAVE D + JSR PC,AMAKE ;B GETS A POINTER TO WINDOW ARRAY + MOV #TVSET, A ;Display window in eraser mode. + CLR D + BR DISWIN + +SHOWWINDOW: ;Display window in IOR mode. + SAVE D + JSR PC,AMAKE + MOV #TVIOR, A + BR DRAWIN + +XORWINDOW: + SAVE D + JSR PC,AMAKE + MOV #TVXOR, A ;XOR mode. + +DRAWIN: MOV #-1.,D +DISWIN: + REST C + SAVE ;Bind drawmode over display of window. + MOV D, WINDATA + JSR PC, DRAWMODE + +; JSR PC,AMAKE +; REST C ;Number of arguments in C. +WINDOW: + DEC C + BEQ 1$ ;NO ARGS INADDITION TO NAME PUT IT AT IT'S CENTER + CMP #2,C + BNE SHWERR ;MUST BE TWO ARGS IF NONE + SPUSH B + JSR PC,G2ARG ;XCEN IN A,Y CEN IN B + SETI + SETF + STF FA,FC + STF FB,FD + JSR PC,TVSCAL + STCFI FA,C + STCFI FB,D + MOV @P,A ;A GETS POINTER TO ARRAY (THIS CHECKS THE BOUNDS OF THE WINDOW) + ADD 16.(A),C ;LEFT EDGE = W CENTER X + DELTA X + ADD 18.(A),D ;TOP EDGE = W CENTER Y +DELTA Y + SAVE ;FOR LATER USE + JSR PC,TVBOUN ;CHECK BOUNDS + MOV 6.(A),B ;RIGHT EDGE=LEFT EDGE + #OF X BITS OF WINDOW + ASH #4,B ;TIMES 16: BITS OF WINDOW = 16 TIMES NUMBER OF WORDS + TST 10.(A) ;IN X - 16 + NUMBER OF BITS THAT DIDN'T TAKE UP A WHOLE WORD. + BEQ 3$ ;TEST FOR SPECIAL CASE WHEN THE WINDOW FITS EXACTLY + SUB #16.,C +3$: ADD 10.(A),B + ADD B,C + ADD 8.(A),D ;BOTTOM=TOP +NUMBER OF LINES (Y DIM) + JSR PC,TVBOUN ;CHECK BOUNDS + REST ;D:TOP F:LEFT EDGE B:POINTER TO ARRAY + BR 4$ +1$: MOV 12.(B),F ;XCEN IN F + MOV 14.(B),D ;YCEN IN D +2$: ;NOW SET UP STACK AND REGISTERS FOR TRANSFER + ADD 16.(B),F ;DIST. FROM ORIGINAL WCENT TO LEFTEDGE + ADD 18.(B),D +4$: CLR E ;FOR DIVIDE + DIV #16.,E + MUL #36.,D ;CALCULATING THE FIRST WORD IN DISPLAY MEMORY + ADD E,D + ASL D ;CONVERT TO BYTES +; ADD #DISAD,D +; SAVE <8.(B)> + ASL F ;CONVERT TO BYTES + SAVE ;SAVE POINTER TO DISPLAY MEM, X INDEX(XDIM),SHIFT + ASR F + NEG F + SPUSH F + MOV 8.(B),A ;A GETS Y INDEX (YDIM) + ADD #HEADER,B + MOV D, TVRADR + CLRB TVINCR +;FALLS THROUGH + ;FALLS IN +LOOP1: MOV 2(P),C ;A:counter y,B:pointer into array C:counter x +;D: pointer into display mem. E:,F: used for shift +;stack @P shift,2(P) counter x needed to restore,4(P) points to next line of disp. mem. +LOOP2: MOV #-1,F ;SET ALL THE BITS IN E FOR THE SHIFT MOV (B)+,F + MOV (B)+,E + ASHC (P),E + BIS 6.(P),E +; COM F ;Write words in F and E on screen. + MOV E, TVMSK ;(This loop can be optimized...) +; MOV D,TVRADR + MOV WINDATA, TVRWIN +; ADD #2.,D +; COM E + MOV F, TVMSK +; MOV D,TVRADR + ADD #2.,TVRADR + MOV WINDATA, TVRWIN +; BIS F,(D)+ +; BIS E,(D) + + SOB C,LOOP2 + ADD #BYTLIN,4(P) + MOV 4(P),TVRADR +; MOV 4(P),D +; ADD 4(P), TVRADR +; ADD 4(P),D + SOB A,LOOP1 + + ADD #8.,P ;CLEAR STACK + REST + SEZ + RTS PC + +; ;TURN OFF TVMAP +; JMP TVMOFF + +;XORWIN: JSR PC,AMAKE +; MOV 2(P),C +; MOV (P)+,(P) +; JSR A,WINDOW +; SPOP A +;LOOP3: MOV 2(P),C +;LOOP4: CLR E +; MOV (B)+,F +; ASHC (P),E +; XOR F,(D)+ +; XOR E,(D) +; SOB C,LOOP4 +; ADD 4(P),D +; SOB A,LOOP3 +; ADD #6,P ;CLEAR STACK +; JMP TVMOFF +; +;ERWINDOW: JSR PC,AMAKE +; MOV 2(P),C +; MOV (P)+,(P) +; JSR A,WINDOW +; SPOP A +;LOOP5: MOV 2(P),C +;LOOP6: CLR E +; MOV (B)+,F +; ASHC (P),E +; BIC F,(D)+ +; BIC E,(D) +; SOB C,LOOP6 +; ADD 4(P),D +; SOB A,LOOP5 +; ADD #6,P ;CLEAR STACK +; JMP TVMOFF + + + +;PRINTSCREEN +PRINTS: JSR PC,TVTEST ;MAKE SURE WE ARE ON A TV + SAVE <#-1,#0,#.LPCAP*400> ;CREAT LINEPRINTER + .INVOK + BNE 1$ + ERROR+DIU +1$: REST TMPCP + JSR PC,LPTFF ;PRINT FORM FEED + SAVE <,#3,TMPCP> + $INVOK ;PUT INTO PLOT MODE, EXPAND BY 3 + MOV #TVRADR,A ;POINT TO THE ADDRESS REGISTER + MOV #454.,B ;NUMBER OF TV LINES + MOV #TVRWIN,E ;POINT TO THE WINDOW + CLR (A) ;START A THE 0 ADDRESS +PRSLP: SAVE <#110,TMPCP> + .WRDO + BEQ PRSERR + MOV #DBUF,C + MOV #110/2,D +1$: MOV (E),F + ADD #2,(A) ;ADD TO GET NEXT WORD + SWAB F + MOV F,(C)+ + SOB D,1$ + SAVE <#DBUF,#-110,TMPCP> + .BLKO + BEQ PRSERR + SOB B,PRSLP + SAVE <,#0,TMPCP> ;GO BACK TO PRINT MODE + $INVOK + JSR PC,LPTFF ;FORM FEED +PRSDON: JSR PC,DELTMP ;Falls thru to TVMOFF. + RTS PC + +LPTFF: SAVE <#14,TMPCP> + .BYTO ;OUTPUT A FORM FEED + BEQ PRSERR ;ERROR, FORGET IT + RTS PC + +PRSERR: JSR PC,PRSDON ;PRINT SCREEN DONE + ERROR+DNR +.ENDC +.ENDC +.ENDC +.ENDC ;LSICOND, BEGINNING AT "TURTLE,DISPLAY,...AND OTHER CRAP" + .SBTTL MUSIC PRIMITIVES + +.IFNZ SITS ;RESUME LSICOND UNTIL END OF MUSIC PRIMITIVES +SING: SAVE D + JSR PC,MCHK + JSR PC,REVS ;FOR MULTIPLE ARGUMENTS + MOV (SP)+,D ;NUMBER OF ARGS + ASR D ;IS IT EVEN? + BCC SING2 + ERROR+WNA ;WRONG NUMBER OF ARGS +SING2: MOV VOICEN,E ;INDEX FOR VOICE (0,2,4 OR 6) + MOV VLAST(E),F ;POINTER TO LAST NODE IN VOICE +SING3: DEC D + BGE SING31 + SEZ + RTS PC +SING31: JSR PC,G2NARG ;DURATION IN B, PITCH IN A + JSR PC,SINGNO ;NORMALIZE MIDDLE C TO 0. ERROR IF NOTE OUT OF RANGE + TST B ;DURATION + BGE SING7 +SING6: ERROR+DOR ;DURATION OUT OF RANGE +SING7: CMP B,#177 ;LARGEST LEGAL DURATION (+- 7 BITS) + BGT SING6 + ADD B,VOICLN(E) ;ACCUMULATE TOTAL FOR VOICE + CMP B,#1 + BLT SING3 ;IF ZERO THEN GO ON + BNE SING8 + NEG B ;IF 1 THEN SET TO -1 AS FLAG FOR PERFORM +SING8: SWAB A + BIC #177400,B ;CLEAR TOP HALF + BIS A,B ;SET UP 8 BITS PITCH, 8 BITS DURATION IN B + JSR PC,ACTSTO ;BUILD ON TO VOICE LIST + MOV F,VLAST(E) ;NEW LAST NOTE + BR SING3 + + +;NORMALIZE MIDDLE C TO 0 +;ERROR IF NOTE OUT OF RANGE. +SINGNO: ADD #74,A ;NORMALIZE 0 TO MIDDLE C + CMP A,#MBTRAP + BEQ SINGN1 + CMP A,#MBREST ;SMALLEST VALID PITCH + BGE SINGN2 +SINGN1: ERROR+NOG ;NOTE OUT OF RANGE +SINGN2: CMP A,#137 ;HIGHEST VALID NOTE + BGT SINGN1 + RTS PC + NOMUSIC: + TST PTBF + BEQ NOMUS1 + MOV #PMBOX,A + JSR PC,TBCHK + BEQ NOMU9 + BIC #INITF,(A) + BR MUSIN +NOMUS1: MOV MBDN,E + JSR PC,CLOSE1 + BNE NOMU9 ;BR IF NOT OPEN ANYWAY + BR MUSIN ;ELSE CLEAR OUT MUSIC VOICES, ETC. + +;TRY TO GET MUSIC BOX AND INITIALIZE +;IF DON'T ALREADY HAVE IT +MCHK: TST PTBF + BEQ MCHK1 + MOV #PMBOX,A + JSR PC,TBCHK + BNE 1$ + ERROR+DNR +1$: BIT #INITF,(A) + BNE NOMU9 + BIS #INITF,(A) + BR MUSIN +MCHK1: MOV MBDN,E + TSTB TTYCPS(E) ;OPEN ALREADY? + BNE NOMU9 ;YES, FORGET IT + JSR PC,OPEN1 +MUSIN: MOV #100,MUCWRD ;FOR NVOICES 4 + MOV #MUSBEG,A +MUSIN1: CLR (A)+ + CMP A,#MUSEND + BLT MUSIN1 + MOV #MVOC,A ;CLEAR OUT THE POINTERS IN USER SPACE + CLR (A)+ + CLR (A)+ + CLR (A)+ + CLR (A)+ + JSR PC,MCL ;SET UP DUMMY NODES + MOV #6,NVOIC ;NUMBER OF VOICES +NOMU9: SEZ + RTS PC + + ;SET UP DUMMY MUSIC LISTS +MCL: MOV #6,F + CLR B + MOV #LSTR,A +MCL2: MOV MVOC(F),TOPS ;FREE MUSIC NODES + JSR PC,FRELST + JSR PC,GRBAD ;GET A NEW NODE + BIS A,C + CLR B + JSR PC,.STORE + MOV C,MVOC(F) ;POINTER TO IT + MOV C,VLAST(F) + CLR VOICLN(F) + SUB #2,F + BGE MCL2 + RTS PC + +MCLEAR: JSR PC,MCHK + JSR PC,MCL + SEZ + RTS PC + VLEN: JSR PC,MCHK ;OUTPUT LENGTH OF CURENT VOICE + MOV VOICEN,B + MOV VOICLN(B),B + JMP R1NARG + +MLEN: JSR PC,MCHK + MOV #4,D + MOV #VOICLN,F + CLR B +MLEN1: MOV (F)+,A ;GET MAXIMUM VOICE LENGTH + CMP A,B + BLE MLEN2 + MOV A,B +MLEN2: DEC D + BNE MLEN1 + JMP R1NARG + +;LIKE TYO, EXCEPT TO MUSIC BOX SPECIFICALLY, ALSO TAKES VARIABLE ARGS, AND CONVERTS +;ARGS TO MUSIC BOX NOTES +MUTYO: SAVE D + JSR PC,REVS + JSR PC,MCHK ;CHECK TO MAKER SURE THAT THE MUSIC BOX IS WHERE IT SHOULD BE + SPOP C ;THE ARGUMENT + BEQ MUTYO2 ;NO CHARACTERS TO SEND BECAUSE NO ARGS +MUTYO1: JSR PC,G1NARG ;B _ CHARACTER + MOV B,A ;COPY IT + JSR PC,SINGNO ;NORMALIZES IT TO MIDDLE C + MOV A,D ;THE CHAR TO OUTPUT + JSR PC,TMBTYO ;TYO THE CHARATER + SOB C,MUTYO1 ;FOR ALL THE CHARACTERS +MUTYO2: .IIF NZ PTBOX,JSR PC,TBREST ;CHANGE BACK TO CONSOLE MODE (NO CHOICE) + SEZ + RTS PC + +;SENDS CONTROL INFO TO THE MUSIC BOX +MUCTRL: JSR PC,MCHK ;CHECK TO MAKE SURE MUSIC BOX IS OPEN + JSR PC,G1NARG ;GET THE ARGUMENT + MOV B,D ;THE ARG + BLT MUCERR ;MUST BE A NUMBER BETWEEN 0,,33 + CMP D,#33. + BLE MUC1 ;FINE +MUCERR: ERROR+WTIB ;BAD ARGMENT TO MUCTRL +;ARG IS DECODED AS FOLLOWS: +; TOP DIGIT IS SILENCE CONTROL, BOTTOM DIGIT IS LOADING CONTROL (BOTH <4) +MUC1: CLR C ;FOR THE DIVIDE + DIV #10.,C ;C_ 10'S D_ UNITS + ASH #4,C ;SHIFT INTO BITS 6,5 + BIC #177774,D ;LEAVE ONLY THE BOTTOM TO BITS + BIS C,D ;SET IN THE SILENCE INFO + BIT #40,D ;BIT 6 CANT EQUAL BIT 7 (ITS A CROCK!!!) + BNE MUC2 ;BIT 6=1 + BIS #100,D ;SO MAKE BIT 7 = 1 +MUC2: MOV D,MUCWRD ;CURRENT CONTROL WORD + JSR PC,MUCTYO ;OUTPUT THAT BYTE +.IIF NZ PTBOX, JSR PC,TBREST ;RESET THE MUSIC BOX (GROAN) + SEZ + RTS PC + GTVARG: JSR PC,G1NARG + DEC B ;TRANSFORM VOICE NUMBER (1,2,3,4) TO INDEX (0,2,4,6) + ASL B + TST B + BGE GTV2 +GTV1: ERROR+IVV ;INVALID VOICE NUMBER +GTV2: CMP B,#6 + BGT GTV1 + RTS PC + +VOICE: JSR PC,MCHK + JSR PC,GTVARG + MOV B,VOICEN + SEZ + RTS PC + +NVOICES: JSR PC,MCHK + JSR PC,MCL ;REINITIALIZE + JSR PC,GTVARG + MOV B,NVOIC ;SET NEW VOICE NUMBER + SEZ + RTS PC + +MBON: MOV MBDN,E + MOV NVOIC,A + ASR A ;TURN INTO BYTE INDEX + MOV A,B + CMP #2,A ;IN NVOICES 3, + BNE MBON1 + INC A ;IT IS NECESSARY TO SILENCE 4 VOICES +MBON1: MOVB MBSCH(A),D ;CHAR FOR A VOICES, BUT ALL SILENT + JSR PC,MUCTYO + MOV #MBREST,D + INC A +MBON2: JSR PC,TBTYO1 ;OUTPUT REST + SOB A,MBON2 + MOVB MBVCH(B),D ;CONTROL CHR FOR NUMBER OF VOICES + MOV D,MUCWRD + JSR PC,MUCTYO ;LEAVE BOX READY FOR NOTES + RTS PC + +;SILENCE MBOX, BUT DON'T CHANGE NUMBER OF VOICES OR ANYTHING +MBOFF: MOV MUCWRD,D + BIC #177774,D ;LEAVE NUMBER OF VOICES INFO INTACT + BIS #100,D + MOV D,MUCWRD + JSR PC,MUCTYO +.IIF NZ PTBOX, JSR PC,TBREST + RTS PC + +;CALLED BY BREAK AND PAUSE TO SHUT THE DAMN THING UP +BRKMOF: MOV MBDN,E + TSTB TTYCPS(E) ;OWN MUSIC BOX + BEQ BRKMO9 ;NO + JSR PC,MBOFF + RTS PC + +;CALLED BY CONTINUE TO TURN MBOX BACK ON +BRKMON: MOV MBDN,E + TSTB TTYCPS(E) ;OWN MUSIC BOX + BEQ BRKMO9 ;NO + MOV MUCWRD,D + JSR PC,MUCTYO +BRKMO9: RTS PC + ;OUTPUT MUSIC TO THE BOX +PM: JSR PC,MCHK + JSR PC,MBON + MOV NVOIC,A + MOV A,F ;USED AS POINTER TO CORRECT VOICE + ADD #VOICLN+2,A ;SET UP FLAGS IN VOICLN SLOTS +PM1: MOV #-1,-(A) + CMP A,#VOICLN + BGT PM1 +PM2: JSR PC,PMCHP ;GRAB DUMMY NODE OF EACH VOICE + JSR PC,PMCHP ;NOW SET UP FIRST NODE OF MUSIC +PM21: SUB #2,F + TST F + BGE PM2 +PM3: TST BRAKE + BNE PM6 + CLR F ;LOOP TO OUTPUT NOTES +PM4: JSR PC,PMNXT ;F IS INDEX TO VOICE + ADD #2,F ;POINT TO THE NEXT ONE + CMP F,NVOIC ;ONE NOTE FROM EACH VOICE + BLE PM4 + CLR B + MOV NVOIC,A ;ADD FLAGS FOR ALL VOICES + ADD #VOICLN+2,A +PM5: ADD -(A),B + CMP A,#VOICLN + BGT PM5 + TST B ;IF ALL FLAGS CLEARED THEN DONE + BNE PM3 +PM6: JSR PC,MBOFF + JSR PC,MCL ;REINIT MUSIC VARIABLES + SEZ + RTS PC + + ;OUTPUT ONE NOTE FROM VOICE(F) +PMNXT: DEC TEMP ;NOTE COUNTER + MOV #MBREST,D + TST VOICLN(F) ;IF FLAG CLEARED OUTPUT REST + BNE PMNXT2 + JSR PC,TMBTYO + RTS PC +PMNXT2: CMPB VLAST(F),#1 ;IF DUR=1 PLAY A REST + BEQ PMNX2A + MOVB VLAST+1(F),D ;PITCH +PMNX2A: JSR PC,TMBTYO + DECB VLAST(F) ;DECREMENT DURATION + BGT PMNXT3 + JSR PC,PMCHP ;IF DUR<=0 SET UP NEXT NODE + RTS PC +PMNXT3: CMPB D,#MBPERC ;IS THIS A PERCUSSION SOUND? + BGT PMNXT4 ;NO + MOVB #MBREST,VLAST+1(F) ;YES--CHANGE ALL BUT FIRST TO RESTS +PMNXT4: RTS PC + +PMCHP: MOV MVOC(F),C ;SET UP NEXT NODE SKIP IF SUCCESSFUL + BIC #170000,C + BNE PMCHP1 + CLR VOICLN(F) ;CLEAR FLAG TO INDICATE NO NEXT NODE + RTS PC +PMCHP1: JSR PC,.LOADC + BIC #170000,A + BIS #LSTR,A + MOV A,MVOC(F) + MOV B,VLAST(F) ;PUT PITCH,,DURATION IN VLAST SLOT + JSR PC,.FREE ;FREE OLD NODE + RTS PC + +TMBTYO: SPUSH C + MOV #PMBOX,C + JSR PC,TBTYO + SPOP C + RTS PC + +MUCTYO: SPUSH D + MOV #MBTRAP,D ;TRAP CHARACTER FOR THE MUSIC BOX + JSR PC,TMBTYO ;OUTPUT IT + SPOP D ;GET BACK ORIGINAL CHARACTER + JSR PC,TBTYO1 ;OUTPUT IT + RTS PC + +TBTYO: JSR PC,TBINIT ;INIT THE PRIVATE THORTON BOX IF OWNED +TBTYO1: SAVE D ;THE CHARACTER TO OUTPUT + TST PTBF ;THORTON BOX PRIVATE? + BEQ 1$ ;NO, USE THE NUMBER IN E + MOV TYICP,-(P) ;USE MY CAPABILITY INSTEAD + BR 2$ ;SKIP CRAP WITH GETTING CAPABILITY NUMBER +1$: CLR -(P) + MOVB TTYCPS(E),(P) +2$: $BYTO ;OUTPUT IT + RTS PC + +TBCHK: TST PTBF + BNE TBCHK2 + RTS PC +TBCHK2: SPUSH B + SPUSH C + MOV #4,B + MOV #PTBTAB,C +TBCHK3: CMPB A,(C) + BEQ TBCHCZ + TST (C)+ + SOB B,TBCHK3 +TBCHSZ: SPOP C + SPOP B + SEZ + RTS PC +TBCHCZ: MOV C,A + SPOP C + SPOP B + CLZ + RTS PC + +CTYOWA: +TYOWAI: + ERROR+SIT +.ENDC ;lsicond + +.ifnz lsi + +tablet: mov tabdev,b ;get tablet word + bmi 1$ ;1st arg: true iff hi bit is 1 + push #false + br 2$ +1$: push #true +2$: mov @s,-(p) ;1st name + movb b,c ;2nd arg: true iff hi bit of lo bite is 1 + bmi 3$ + push #false + br 4$ +3$: push #true +4$: mov s,f ;2nd name + mov 2(f),-(p) + swab b ;3rd arg: hi byte minus its hi bit + bic #-200,b + jsr pc,.csnin + push b + mov 4(f),-(p) ;3rd name + movb c,b ;4th arg: lo byte minus its hi bit + bic #-200,b + jsr pc,.csnin + add #6,s + pushs b ;now set up 4 thing/name pairs on the spdl + pushs (p)+ + pushs (p)+ + pushs (p)+ + pushs (p)+ + pushs (p)+ + pushs (p)+ + jsr pc,mmake9 ;& do 4 calls to make + jsr pc,mmake9 + jsr pc,mmake9 + jmp mmake9 +.endc diff --git a/src/nlogo/eval.119 b/src/nlogo/eval.119 new file mode 100755 index 00000000..fa92c04b --- /dev/null +++ b/src/nlogo/eval.119 @@ -0,0 +1,7647 @@ + .SBTTL SYSTEM PRIMITIVES + VERSIO + +.GLOBL .CRLF,ARGMSK,HOUR,NUMOBS,OPTS,PCHR,SECOND,SOBLST,SSTATS,STIME,VARIAB,YEAR ;001 + +.OPTIO: MOV #OPTS,A + JSR PC,PRAS +.OPTI1: SEZ + RTS PC + +.PRIMI: MOV #SOBLST+2,F +9$: MOV (F)+,B + ADD #SOBLST,B + BIT #VARIAB*400,(B) + BEQ 1$ + PRTXT <(> +1$: MOV B,A + CMP (A)+,(A)+ + JSR PC,PRAS + MOV #'A,D + MOVB 1(B),C + BIC #ARGMSK,C + BEQ 3$ +2$: PRTXT < :> + JSR PC,@PCHR + INC D + SOB C,2$ +3$: BIT #VARIAB*400,(B) + BEQ 4$ + PRTXT <)> +4$: JSR PC,.CRLF + CMP F,#SOBLST+ + BLO 9$ + SEZ + RTS PC + +.IFNZ ENG&FR +ENGLIS: +ANGLAI: MOV #ENGFLG,LANG +ENG1: SEZ + RTS PC +FRENCH: +FRANCAIS: MOV #PFRFLG!FRFLG,LANG + BR ENG1 +FRANGLAIS: BIS #ENGFLG!FRFLG,LANG + BR ENG1 +.ENDC + .GLOBL WTA,S,TOPS,UDA,WTAB ;003 +;THIS IS THE STUFF FOR ARRAY HACKING +AMAKE: ASL D + ADD S,D + MOV -(D),A ;ADDR OF ARRAY NAME +AMAKE5: MOV A,B + BIC #7777,A + CMP #ATOM,A ;IS A TYPE ATOM? + BNE AMAKE3 ;NO +AMAKE4: MOV #ABIND,A + JSR PC,.BINDL + BEQ AMAKE6 + JMP CLRTOP + +AMAKE3: CMP #LSTR,A ;IS A TYPE LSTR? + BNE AMAKE2 ;YES + BIT #7777,B ;NULL POIMTER? + BEQ AMAKE2 ;YES + MOV B,TOPS + JSR PC,UOBSCH ;GET ATOM + BNE AMAKE4 +AMAKE6: ERROR+UDA +AMAKE2: ERROR+WTAB + + + +.GLOBL HEADER ;004 +.GLOBL ROB,WNA ;004 +ARRAD: MOV B,E + SPUSH E ;TOP OF ARRAY HEADER + CMPB 4(E),F ;IS DIM=NO. OF INDICES? + BEQ ARRAD1 ;YES + ERROR+WNA ;WRONG NO OF ARGS +ARRAD1: CLR A ;TEMP ACCUMULATOR + ADD #12,E ;LENGTH OF DIMENSION IN E +ARRAD2: JSR PC,G1NARG ;GET INDEX OFF S-PDL + CMP B,(E) ;INDEX IN BOUNDS? + BGE ARRAD4 ;NO + TST B ;NEGATIVE INDEX? + BGE .+4 ;INDEX OK +ARRAD4: ERROR+ROB + ADD B,A + DEC F + BEQ ARRAD3 ;MORE INPUT + MUL -(E),A + MOV B,A + BR ARRAD2 +ARRAD3: SPOP E ;ADDR OF ARRAY HEADER + TSTB 5(E) ;IS TYPE PTR? + BEQ 1$ + ASL A +1$: ASL A ;TOTAL OFFSET (A*4) + ADD #HEADER,A ;ADDR OF FIRST VALUE + ADD E,A ;ADDR OF VALUE TO BE STORED + RTS PC + +STORE: SAVE D + JSR PC,AMAKE + SPOP F ;NO. OF ARGUMENTS + SUB #2,F + POPS D ;VALUE TO BE STORED + JSR PC,ARRAD ;FIND STORAGE LOCATION + MOV A,F + MOV 4(E),A + MOV D,B + BIC #7777,A + BEQ STORE1 + JSR PC,CONVERT + BNE 1$ + ERROR+WTAB +1$: JSR PC,.LOADB + MOV A,(F)+ +STORE1: MOV B,(F) ;VALUE IS NOW STORED + ADD #2,S +SRTSPC: SEZ + RTS PC + + +GET: SAVE D + JSR PC,AMAKE + SPOP F ;NO. OF ARGUMENTS + DEC F ;NO. OF INDICES + JSR PC,ARRAD ;COMPUTE STORAGE LOCATION + MOV A,F ;STORAGE LOCATION ADDR IN F + MOV (F),C + TSTB 5(E) ;TEST TYPE + BEQ GET1 ;TYPE 0 (PTR) + MOV (F)+,A + MOV (F),B + JSR PC,GRBAD ;STORES VALUE IN NODE SPACE + MOV 4(E),D + BIC #7777,D + BIS D,C ;SET TYPE ON PTR TO VALUE +GET1: MOV C,@S ;PTR ON TOP OF S-PDL + CLZ + RTS PC + + ;DEFINE AN ARRAY +.GLOBL ERW,LIMIT,WDIM,BAT,ASPACE,ARTOP,NAS,.RELES,..ALLO,TMPBLK + +DEFAR: MOV D,F + CMP F,#LIMIT+2 ;WHICH SHOULD BE < ALLOWABLE LIMIT + BLE OKARAY ;OKAY,THIS IS. +AERROR: ERROR+WDIM +OKARAY: SUB #2,F ;DIMENSION OF ARRAY IN F + MOV F,A + MOV #1,D ;SET UP FOR MULTIPLICATION + JSR PC,G1NARG ;GET TYPE + MOV B,E ;SAVE IT + BEQ ALNUM ;0 FOR LNUM +.IFNZ FPPF + CMP #1,B + BEQ AFNUM ;1 FOR FNUM +.ENDC + CMP #2,B + BEQ NXTIDX ;2 FOR PTR + ERROR+BAT +ALNUM: BIS #LNUM,F + BR NXTIDX +.IFNZ FPPF +AFNUM: BIS #FNUM,F +.ENDC +NXTIDX: JSR PC,G1NARG ;GET MAGNITUDE OF LAST DIMENSION + PUSH B ;SAVE THIS DIMENSION + MUL B,D ;D IS ODD + BLE AERROR ;DIMENSION < 0 + BCS AERROR ;DIMENSION TOO BIG + SOB A,NXTIDX + SPUSH F ;SAVE DIMENSION OF ARRAY + BIT #160000,D ;SIZE SHOULD NOT BE TOO BIG + BNE AERROR + CMP #2,E ;IS THIS PTR ARRAY + BEQ WALLOC + ASL D ;THIS IS DOUBLE PRECISION ARRAY +WALLOC: ASL D ;TO CONVERT TO BYTES + ADD #HEADER,D + SPUSH D ;SAVE SIZE OF ARRAY BLOCK + MOV @S,B ;GET NAME OF ARRAY + MOV B,A + BIC #7777,A ;SEE WHETHER IT HAS BEEN INTERNED? + CMP #ATOM,A ;BY TESTING ITS TYPE + BEQ FABIND ;YES + CMP #LSTR,A ;NO,IS NAME ALL RIGHT + BEQ 1$ ;YES + ERROR+WTAB +1$: MOV B,TOPS + JSR PC,UINTRN ;INTERN NAME OF ARRAY + MOV B,@S ;SAVE UOE PTR +FABIND: CLR TOPS ;NOT TO CHANGE BINDING + MOV #ABIND,A ;SEE IF AN ARRAY IS + JSR PC,.BIND ;BINDED TO THIS NAME + BEQ GETSPA ;NO + MOV C,@S ;SAVE PTR TO BINDING NODE + MOV B,C + MOV 2(C),B + ADD ASPACE,B ;ADDED TO AVAILABLE FREE SPACE +.IF NZ SITS + ADD #_13.+ARYAD,B ;TOTAL POSSIBLE ARRAY SPACE + SUB ARTOP,B ;AMOUNT OF CORE GOTTEN SO FAR +.ENDC + CMP B,(P) ;IS SUM ENOUGH FOR NEW BINDING? + BGE ERAOLD ;YES +FULL: ERROR+NAS ;NOT ENOUGH SPACE +ERAOLD: MOV C,B + JSR PC,.RELES ;RELEASE OLD BINDING +;FALLS THROUGH + ;FALLS IN +GETSPA: SPOP B ;GET SIZE OF ARRAY + MOV B,D ;SAVE IT + JSR PC,..ALLOC ;ASSIGN SPACE + BEQ FULL ;NOT ENOUGH + SPOPS B ;UOE PTR + SPUSH A ;PUSH IT ON THE P PDL + MOV P,(A) ;MAKE THE ARRAY POINT BACK TO THE PDL SLOT + MOV #ABIND,A + MOV #LSTR,TOPS ;HAVE TO BIND IT TO SOMETHING + JSR PC,.BIND ;BIND NEW ARRAY + BIC #170000,C ;PTR TO BINDING NODE + ASL C + ASL C + ADD #NODESP+2,C ;THIS IS PHYSICAL ADDR OF BINDING NODE + SPOP A ;GET BACK POINTER TO THE ARRAY + MOV A,TMPBLK ;FOR MAKEWINDOW + MOV A,(C) ;MAKE THE BINDING NODE POINT TO THE ARRAY + MOV C,(A)+ ;BACK PTR FIRST ENTRY IN HEADER + MOV (A)+,D ;SIZE OF ARAY SECOND + SPOP F + MOV F,(A)+ ;DIMENSION OF ARRAY THIRD + ADD #LIMIT*2,A ;TO ADVANCE (A) + BIC #177400,F ;GET DIMENSION PART + MOV F,E + ASL E ;TO GET IT INTO BYTES + SUB E,A ;FOR OFFSET INTO HEADER +1$: SPOP (A)+ + SOB F,1$ + MOV (C),A + CLR C ;FOR CLEARING THE ARRAY + BIT #170000,4(A) ;IS IT A POINTER ARRAY? + BNE 2$ ;NO + MOV #LIST,C ;FILL IT WITH EMPTY LISTS +2$: ADD #HEADER,A + SUB #HEADER,D + ASR D +3$: MOV C,(A)+ ;ZERO ARRAY VALUES + SOB D,3$ + JMP CLRTOP + + .GLOBL RTB ;014 +ERARAY: JSR PC,GTUOEB ;GET NEXT TOKEN + BNE ERARA1 +ERARA2: CLR TOPS + MOV #ABIND,A + MOV B,F + JSR PC,.BIND + BEQ ERARAR + JSR PC,.RELES ;RELEASE ARRAY BLOCK + MOV F,B + JSR PC,.UNBND +ERARAR: SEZ + RTS PC + +ERARA1: CMP #UFUN,A + BGT 1$ + ERROR+ERW +1$: JSR PC,CVSFLS + MOV #ATOM,A + JSR PC,.OBSCH + BNE ERARA2 + RTS PC + + +ERARAS: JSR PC,GNOLEI +ERARS1: JSR PC,GNOLE + BEQ ERARAR + MOV B,F + CLR TOPS + MOV #ABIND,A + JSR PC,.BIND + BEQ ERARS1 ;THIS NAME HAS NO ARRAY BINDING + JSR PC,.RELES ;RELEASE THIS ARRAYY + MOV F,B + JSR PC,.UNBND + BR ERARS1 + + +;RETURNS SIZE OF ARRAY DIMENSIONS +ASIZEX: POPS A ;GET THE ARRAY NAME + JSR PC,AMAKE5 ;FINDS THE START OF THE ARRAY +ASIZE2: PUSH E + MOV B,E + MOVB 4(E),D ;TYPE/DIM WORD + MOV D,F + SPUSH D ;SAVE IT + ASL D ;SETS UP OFFSET FOR DIMENSION WORD + SUB D,E + ADD #14,E ;ADDR. OF FIRST DIM. +ASIZE1: MOV (E)+,B + JSR PC,.CSNIN ;CONVERT TO INUM AND PUT IN NODE + SPUSHS C ;SAVE PTR ON S-PDL + SOB F,ASIZE1 ;CHECK FO MORE DIMS. + SPOP D ;NO OF DIMS. IN D + JSR PC,SENT. ;LINK DIMS. IN LIST + POP E + CLZ + RTS PC + + +.SBTTL ARITHMETIC ROUTINES +.IFNZ FPPF + +;FLOATING POINT MACROS + +.MACRO FPUSH FF + STF FF,-(P) + JSR PC,PPUSHT +.ENDM + +.MACRO FPOP FF + LDD (P)+,FF + JSR PC,PPOPT +.ENDM + +.ENDC + + +.IFZ FPPF + +;SINGLE PRECISION ARITHMETIC ROUTINES + +UPLUS: CLZ ;UNARY PLUS - NOTHING TO DO + RTS PC +UMINS: JSR PC,G1IARG ;UNARY MINUS + DPNEG B,C +DONBC: JMP R1I.BC + +SUM: + CLR E + CLR F + TST D + BLE DIFF.2 ;DONE +SUM.1: JSR PC,G1IARG ;GET 1 INTEGER + DPADD B,C,E,F + DEC D ;COUNTER + BGT SUM.1 + BR DIFF.2 ;DONE + +DIFF: + JSR PC,G2IARG ;GET 2 INTEGERS + DPSUB B,C,E,F +DIFF.2: CMP E,#100000 ;IS ANSWER = 100...00 ? + BNE DONEMP + TST F ;IF SO , THEN ERROR + BNE DONEMP + ERROR+RTB ;SINCE THAT IS SMALLEST NEG NUMBER +DONEMP: JMP R1I.EF + +PROD: + CLR E + MOV #1,F +PROD.1: DEC D + BLT DONEMP ;DONE + JSR PC,G1IARG ;GET ONE ARG IN B + JSR PC,.DPMUL + BNE PROD.1 + ERROR+RTB ;RESULT TOO BIG + +MOD: + JSR PC,G2IARG + JSR PC,.DPDIV + BNE DONBC + ERROR+RTB + +DIVDE: +DIV.1: JSR PC,G2IARG + JSR PC,.DPDIV + BNE DONEMP + ERROR+RTB + + +.ENDC + + +.IFNZ FPPF + + +;FLOATING POINT ARITHMETIC ROUTINES + +ERRET: ERROR+RTB +UPLUS: CLZ + RTS PC +UMINS: MOV #INUM,F + JSR PC,G1ARG + LDD FA,FB + NEGF FB + BR .FSTOR ;STORE FB +DIFF: JSR PC,G2ARG ;LOAD FA AND FB + SUBF FA,FB + CFCC + BVS ERRET ;OVERFLOW? + BR .FSTOR ;STORE IT +SUM: MOV #INUM,F + CLRF FB + TST D + BLE .FSTOR +SUM.1: JSR PC,G1ARG ;GET A NUMBER + ADDF FA,FB + CFCC + BVS ERRET ;OVERFLOW? + DEC D + BGT SUM.1 ;ADD MORE NUMBERS + BR .FSTOR ;DONE AT LAST +PROD: MOV #INUM,F + LDCFD #40200,FB ;LOAD CONSTANT "1" + TST D + BLE .FSTOR ;DONE ALREADY +PROD.1: JSR PC,G1ARG + MULF FA,FB + CFCC + BVS ERRET ;OVERFLOW? + DEC D + BGT PROD.1 ;LOOK AT COUNTER + +;FALLS THROUGH + ;FALLS IN +;THIS TAKES A NUMBER OUT OF FB AND +;CONVERTS IT ACCORDING TO TYPE IN REG F (INUM,FNUM) +;AND RETURNS + +.FSTOR: CMP #FNUM,F ;FNUM OR INUM? + BEQ .FST.2 + STCFI FB,-(P) ;PUT INUM ON STACK + BCS ERRET ;OVERFLOW? +.FST.1: SPOP A + SPOP B + JSR PC,GRBAD ;STORE ANSWER + BIS F,C ;SET TYPE + JMP ORTC +.FST.2: STCDF FB,-(P) ;PUT FNUM ON STACK + JMP .FST.1 +DIVDE: JSR PC,G2ARG ;GET ARGS + TSTF FA ;TEST ZERO DIVIDE + CFCC + BEQ ERRET ;IT WAS!!?? + DIVF FA,FB + CFCC + BVS ERRET ;OVERFLOW? + BR .FSTOR ;STORE IT +MOD: JSR PC,G2ARG ;GET ARGUMENTS IN FA AND FB + SPUSH #.FSTOR +.MOD: TSTF FA ;IS FA 0? + CFCC + BEQ ERRET ;IT IS?? + LDD FB,FC ;FC <- FB + DIVF FA,FC ;FC <- (FB/FA) + CFCC + BVS MOD2 ;THE ANSWER IS 0 + MODD #40200,FC ;SEPERATE INTEGER AND FRACTION PARTS + MULF FA,FD ;FD <- FA * (INT (FB/FA)) + SUBF FD,FB ;FB <- MOD (FB,FA) +MOD1: CFCC + BGE MOD3 ;IS IT POSITIVE? + ADDF FA,FB ;NO, ADD FA + BR MOD1 +MOD2: CLRF FB +MOD3: RTS PC + + +.GLOBL GCPREV ;016 +SQRT: MOV @S,GCPREV ;SAVE THIS WORD + JSR PC,G1NUM + BNE SQRT2 +SQRT1: MOV GCPREV,B ;GET POINTER TO NUMBER OR ARGUMENT + ERROR+WTAB +SQRT2: TSTF FA + CFCC + BMI SQRT1 + BEQ SQRTRT + CLR GCPREV ;NO NEED FOR THIS ANYMORE. + LDF FA,FB + STEXP FA,A + LDEXP #0,FA + ASR A + ADC A + ADDF #40000,FA + BCS 1$ + ADDF #40000,FA +1$: CLRF FC + LDEXP A,FC + MULF FC,FA + MOV #4,A +SQRTLP: LDF FB,FC ;FC <= X + DIVF FA,FC ;FC <= X/Y + ADDF FC,FA ;FA <= Y + X/Y + MULF #40000,FA ;FA <= 1/2 * (Y + X/Y) + SOB A,SQRTLP +SQRTRT: MOV #FNUM,F + STCDF FA,-(P) + JMP .FST.1 + + +; CALL WITH D POINTING TO CURX OR CURY. +; RETURN THE INTEGER OF CURX OR CURY IN B +GETINT: MOV (D)+,B ;THE FRACTION PART + ROL B + MOV (D)+,B ;THE INTEGER PART + ADC B ;ROUND + RTS PC + + .GLOBL PI ;019 +.GLOBL ACOPI,ATANTB,PITWO,TMNI ;020 +SINEF: MOV #SINDEG,E +SINEF1: JSR PC,G1NUM ;FA <- ARGUMENT + BNE 1$ + ERROR+WTAB ;WRONG TYPE OF ARG +1$: JSR PC,(E) ;FA <- SINE (FA) +COSF1: MOV #FNUM,F ;TELL .FST.1 IT'S AN FNUM + STCDF FA,-(P) ;PUT SINE ON STACK FOR .FST.1 + JMP .FST.1 ;PUT IT INTO A NODE +COSF: MOV #COSDEG,E + BR SINEF1 + +SINDEG: MOV #-1,A + BR TRIG +COSDEG: MOV #1,A +TRIG: MOV #1,B + TSTF FA + CFCC + BGE TRIG1 + NEGF FA + MUL A,B +TRIG1: DIVF #41464,FA ;DIVIDE BY 45 + MODD #40200,FA ;SEPERATE FRACTION AND INTEGER + MODD #37400,FB + MULF #41000,FB ;MOD 8 + SETI + STCFI FB,C + SETL + ASL C + ADD C,PC + BR .TRIG0 + BR .TRIG1 + BR .TRIG2 + BR .TRIG3 + BR .TRIG4 + BR .TRIG5 + BR .TRIG6 + MUL A,B + BR .TRIG7 +.TRIG6: MUL A,B + NEG A + BR .TRIG0 +.TRIG4: NEG B + BR .TRIG0 +.TRIG3: NEG B + MUL A,B + BR .TRIG7 +.TRIG2: NEG A + MUL A,B + BR .TRIG0 +.TRIG5: NEG B +.TRIG1: NEG A +.TRIG7: SUBF #40200,FA ;WE WANT 45 - ANGLE + NEGF FA +;FALLS THROUGH + ;FALLS IN +.TRIG0: MULF PI,FA + MULF #37600,FA ;CONVERT FROM DEGREES TO RADIANS + LDD FA,FD + MULF FD,FD + NEGF FD ;-ANGLE SQUARED INTO FD + LDCFD #40200,FB ;COUNTING CONSTANT "1" + STF FB,FF + TST A + BLT .TRIG9 ;WE WANT SIN + LDD FB,FA + CLRF FB +.TRIG9: LDD FA,FC + TSTF FD + CFCC + BEQ TRIG11 +TRIG10: ADDF FF,FB + DIVF FB,FC + ADDF FF,FB + DIVF FB,FC + MULF FD,FC + ADDF FC,FA + CMPF #41100,FB + CFCC + BGE TRIG10 +TRIG11: TST B + BGE 1$ + NEGF FA +1$: RTS PC + +;ARCTAN ROUTINE +;ARG RECEIVED & RETURNED IN FA +;CALL ARG "X"; IT KEEPS CHANGING AS IT PASSES THRU THESE ROUTINES +ATAN: JSR PC,G1ARG ;ARG IN FA, DOES SEZ IF IT FINDS A NUMBER + BNE 2$ ;DID WE GET A NUMBER? + ERROR+WTA ;NO +2$: SETD ;DOUBLE PRECISION + +;IF X >= 0, ATAN(X) = 180/PI * ATAN1(X) +;IF X < 0, ATAN(X) = -180/PI * ATAN1(-X) + LDD ACOPI,FD ;FD = 180/PI + STD FD,FE ;SAVE IT IN FE + TSTD FA ;X >= 0? + CFCC + BGE 1$ ;IF SO, BRANCH + NEGD FA ;FA = -X + NEGD FE ;FE = -180/PI +1$: JSR PC,ATAN1 + MULD FE,FA ;RESULT IN FA + JMP COSF1 ;RETURN ARG + +;IF X < 10**-9, ATAN1(X) = X +;IF X > 1, ATAN1(X) = PI/2 - ATAN2(1/X) +;ELSE ATAN1(X) = ATAN2(X) +ATAN1: CMPD TMNI,FA ;IS 10**-9 > X? + CFCC + BGT ATAN1B ;YES, X SMALL SO OUTPUT X + CMPD #40200,FA ;1 < X? + CFCC + BGE ATAN2 ;YES, SO OUTPUT ATAN2(X) + LDD #40200,FB ;LOAD A 1 INTO FB + DIVD FA,FB ;FB = 1/X + LDD FB,FA ;TRANSFER TO FA + JSR PC,ATAN2 ;ATAN2(1/X) + LDD PITWO,FB ;FB = PI/2 + SUBD FA,FB ;FB = PI/2 - ATAN2(1/X) + LDD FB,FA ;TRANSFER TO FA +ATAN1B: RTS PC + +;ATAN2(X) = (X*(B0+(A1/(Z+B1+(A2/(Z+B2+(A3/(Z+B3)))))))) + ;WHERE Z = X**2 + ;INTERMEDIATE RESULT CALLED "OP" +ATAN2: LDD FA,FB ;FA CONTAINS X + MULD FB,FB ;FB = X**2 + MOV #ATANTB,D ;POINT TO TABLE OF CONSTANTS + + LDD FB,FC ;FC = Z + ADDD (D)+,FC ;FC = B3 + Z + + LDD (D)+,FD ;FD = A3 + DIVD FC,FD ;FD = A3/OP; FD = NEW OP + + LDD (D)+,FC ;FC = B2 + ADDD FB,FC ;FC = Z + B2 + ADDD FD,FC ;FC = FC + OP; FC = NEW OP + + LDD (D)+,FD ;FD = A2 + DIVD FC,FD ;FD = A2/OP; FD = NEW OP + + ADDD (D)+,FB ;FB = Z +B1 + ADDD FD,FB ;FB = FB + OP; FB = NEW OP + + LDD (D)+,FD ;FD = A1 + DIVD FB,FD ;FD = A1/OP; FD = NEW OP + + ADDD (D)+,FD ;FD = OP + B0 + MULD FD,FA ;FA = OP * X + RTS PC + +.ENDC + + +.GLOBL NUM1,NUM1E,NUM2,NUM2E ;021 +.IFNZ SARITH +;STRING PLUS JUST ADDS ITS TWO NUMBERS BY LINEARIZING THEM INTO NUM1 AND NUM2 +;IT THEN ADDS THEM IN 9'S COMPLEMENT, RECONVERTING THE NUMBER IF NEEDED. +STNGPL: JSR PC,LIN2AR ;LINEARIZE THE TWO ARGS INTO NUM1 AND NUM2 + ;ALSO SET UP NUM1E AND NUM2E +;THIS ENTRY ALSO USED BY STRING MINUS +STNGAD: MOV NUM1E,B ;GET THE NUMBER OF DIGITS TO ADD TOGETHER + SUB #NUM1,B ;TURN IT INTO THE LENGTH + CLR C ;NO CARRY +ADDLOP: DEC B ;DEC POINTER + MOVB NUM1(B),D ;GET THE FIRST DIGIT + MOVB NUM2(B),E ;GET SECOND DIGIT + ADD D,E ;GET SUM + ADD C,E ;ADD IN THE CARRY + CLR C ;CLEAR THE CARRY FOR NEXT TIME + CMP E,#10. ;IS IT TOO BIG + BLO 1$ ;NO, JUST GO AHEAD + INC C ;SET CARRY + SUB #10.,E ;AND MAKE IT SMALL AGAIN +1$: MOVB E,NUM2(B) ;AND PUT IT BACK IN THE LIST + TST B ;ARE WE DONE YET? + BNE ADDLOP ;NOPE, CONTINUE +2$: CLR C ;THE SIGN IS POSITIVE + TSTB NUM2 ;IS THE RESULT NEGATIVE? + BEQ 3$ ;NO, IGNORE THIS + MOV NUM2E,B ;END IN B + MOV B,A ;COPY IT + SUB #NUM2,A ;GET POINTER TO THE NUMBER + JSR PC,COMPL ;COMPLEMENT IT + MOV #1,C ;SET NEGATIVE FLAG +3$: MOV #NUM2,A ;GET POINTER TO THE NUMBER + MOV NUM2E,B ;GET END OF NUMBER TO MAKE +;;; FALLS IN TO RETURN A STRING NUMBER + +;;; A POINTS TO THE NUMBER, B THE END, AND C THE SIGN +RETSNG: JSR PC,BLSTI ;MAKE A LIST + TST C ;IS THE RESULT NEGATIVE? + BEQ 1$ ;NO, DO NOTHING + MOV #'-,D ;PUT A MINUS SIGN IN FRONT + JSR PC,BLST +1$: CMP A,B ;ARE WE AT THE END? + BEQ 2$ ;YES, JUST PRETEND WE HAVE FOUND NON ZERO BYTE + TSTB (A)+ ;IS IT 0? + BEQ 1$ ;YES, JUST CONTINUE +2$: TSTB -(A) ;BACK UP TO THE NON-ZERO WORD +3$: MOVB (A)+,D ;GET THE NUMBER + ADD #'0,D ;CONVERT IT TO ASCII + JSR PC,BLST ;AND BUILD IT ONTO THE LIST + CMP B,A ;IS IT AT THE START OF NUMBER? + BNE 3$ ;NO, GO BACK FOR NEXT DIGIT + JSR PC,BLSTF ;GET POINTER TO STRING IN TOPS + PUSHS TOPS ;PUSH IT ON THE OUTPUT PDL + CLR TOPS + CLZ + RTS PC ;WE ARE RETURNING A NUMBER STRING + +STNGMI: JSR PC,LIN2AR ;LINEARIZE THE ARGS AND RETURN THE LENGTH IN A + MOV NUM1E,B ;POINTER TO THE END OF NUM1 + JSR PC,COMPL ;COMPLEMENT IT + BR STNGAD ;NOW PRETEND IT IS AN ADD + +;LINEARIZE TWO ARGS OFF THE S PDL +LIN2AR: MOV #NUM1,A ;POINTER TO THE FIRST AREA + JSR PC,LINEAR ;LINEARIZE THE NUMBER INTO NUM1 + MOV A,NUM1E ;THE END OF THE FIRST NUMBER + SPUSH B ;SAVE THE SIGN + MOV #NUM2,A ;AND THE SECOND AREA + JSR PC,LINEAR ;DO THE SAME FOR THE SECOND NUMBER + MOV A,NUM2E + SPUSH B ;SAVE THE SIGN AGAIN + MOV A,B ;COPY POINTER TO NUM2E + SUB NUM1E,B ;GET THE DIFFERENCE IN LENGTHS + SUB #NUM2-NUM1,B ;SUBTRACT OFFSET + BEQ SINCAL ;NO DIFFERENCE, JUST DO SIGNS + BPL 1$ ;(NUM2 IS LONGER THAN NUM1) + NEG B ;MAKE IT POSITIVE (NUM1 IS LONGER THAN NUM2 HERE) + MOV #NUM2,D ;POINTER TO THE START OF THE NUMBER + ADD B,NUM2E + BR 2$ ;BLT UP NUM2 POINTER IN A +1$: MOV NUM1E,A ;POINTER TO NUM1 WHICH WE WILL BLT UP + MOV #NUM1,D ;POINTER TO THE START OF NUM1 + ADD B,NUM1E ;MAKE BOTH THE MAXIMUM +2$: MOV A,C ;COPY POINTER TO THE END + ADD B,C ;THE NUMBER OF BYTES WE ARE MOVING IT UP BY +BLTLOP: MOVB -(A),-(C) ;BLT DOWN THE NUMBER + CMP A,D ;POINTER TO THE START OF THE NUMBER + BNE BLTLOP +CLRLOP: CLRB -(C) ;CLEAR OUT THE REST OF THE AREA + CMP C,D + BNE CLRLOP ;NOW WE HAVE THE NUMBERS THE SAME LENGTH IN NUM1 AND 2 +SINCAL: MOV NUM1E,A ;THE NUMBER OF BYTES TO CONVERT + SUB #NUM1,A ;GET THE LENGTH IN A + TST (P)+ ;IS THE SECOND NUMBER NEGATIVE? + BEQ 1$ ;NO + MOV NUM2E,B ;POINTER TO THE NUMBER TO NEGATE + JSR PC,COMPL ;GET 9'S COMPLEMENT +1$: TST (P)+ ;IS THE FIRST NEGATIVE? + BEQ 2$ ;NO ALL DONE + MOV NUM1E,B ;POINTER TO THE NUMBER + JSR PC,COMPL +2$: RTS PC + +STNGML: JSR PC,STNG2U ;GET TWO UNSIGNED ARGUMENTS FOR + MOV #NUM3,A ;GET POINTER TO THE RESULT AREA + MOV #NUM3EN-NUM3,B ;CLEAR OUT THE WHOLE AREA +1$: CLRB (A)+ + SOB B,1$ + MOV #TMPBLK,A ;GET POINTER TO THE DATA AREA + MOV #NUM1,(A)+ ;POINTER TO THE FIRST ARG + MOV NUM1E,(A) + SUB #NUM1,(A)+ ;GET THE LENGTH OF THE FIRST ARG + MOV #NUM2,(A)+ ;POINTER TO THE SECOND ARG + MOV NUM2E,(A) + SUB #NUM2,(A)+ ;GET THE LENGTH OF THE SECOND ARG + CMP TMPBLK+2,TMPBLK+4 ;COMPARE THE LENGTHS + BGE 2$ ;WE WANT THE FIRST ARGUMENT TO BE THE SHORTEST + SPUSH TMPBLK ;EXCH TMPBLK,TMPBLK+4 + MOV TMPBLK+4,TMPBLK + SPOP TMPBLK+4 + SPUSH TMPBLK+2 ;EXCH TMPBLK+2,TMPBLK+6 + MOV TMPBLK+6,TMPBLK+2 + SPOP TMPBLK+6 +2$: SPUSH #NUM3EN ;POINTER FOR THIS PRODUCT TO BE ADDED IN AT + ADD TMPBLK+6,TMPBLK+4 ;MAKE IT POINT TO THE END OF THE SHORTER NUMBER +;;; HERE TMPBLK LOOKS LIKE THIS +;;; TMPBLK: POINTER TO THE LONGER NUMBER +;;; LENGTH OF THE LONGER NUMBER +;;; POINTER TO THE END OF THE SHORTER NUMBER +;;; LENGTH OF THE SHORTER NUMBER +;;; ON THE STACK IS A POINTER TO THE PLACE TO ADD IN THE CURRENT PARTIAL PRODUCT +NXTBYT: DEC TMPBLK+6 ; COUNT OF BYTES LEFT IN THE SHORTER NUMBER + BLT MULDON ;DONE IF IT COUNTS DOWN + DEC TMPBLK+4 ;MOV -(TMPBLK+4),C + MOVB @TMPBLK+4,C + MOV (P),F ;OUTPUT POINTER + DEC (P) ;FOR NEXT TIME + MOV TMPBLK+2,D ;COUNT OF DIGITS IN LONGER NUMBER + MOV TMPBLK,E ;POINTER TO THE LONGER NUMBER + ADD D,E ;SET UP POINTER TO THE END OF LONGER NUMBER + CLR A ;NO CARRY TO START +;;; HERE WE HAVE THE REGISTERS SET UP AS FOLLOWS: +;;; A: CARRY FROM PREVIOUS MUL +;;; B: SCRATCH +;;; C: MULTIPLIER DIGIT FROM SHORT NUMBER +;;; D: COUNT OF DIGITS IN LONGER NUMBER +;;; E: POINTER TO THE NEXT DIGIT IN LONGER NUMBER +;;; F: OUTPUT POINTER +MULLOP: CMP F,#NUM3 ;OVERFLOWED AREA? + BLOS MULBER ;TOO BIG A NUMBER + MOVB -(E),B ;PICK UP NEXT DIGIT IN LONG NUMBER + MUL C,B ;MULTIPLY AND ADD IN CARRIES + ADD A,B + MOVB -(F),A ;AND ADD IN PREVIOUS CONTENTS + ADD A,B + CLR A ;FOR DIVIDE + DIV #10.,A ;A: THE CARRY, B IS THE DIGIT + MOVB B,(F) ;PUT IT BACK + SOB D,MULLOP ;AND DO REST OF LONG NUMBER + TST A ;ANY CARRY OUT OF HIGH PART OF NUMBER? + BEQ NXTBYT ;NO, GO ON TO THE NEXT DIGIT IN THE SHORT NUMBER + CMP F,#NUM3 ;WILL WE OVERFLOW? + BLOS MULBER ;YES + MOVB A,-(F) ;STORE IT AWAY (MUST BE A 0 BYTE (F) NOW) + BR NXTBYT ;GO DO REST OF SHORT NUMBER +MULDON: TST (P)+ ;POP OFF THE START POINTER + MOV #NUM3EN,B ;POINTER TO THE END OF THE NUMBER + MOV #NUM3,A ;POINTER TO THE START OF THE NUMBER TO RETURN + MOV NUM1S,C ;GET SIGN OF FIRST + MOV NUM2S,D ;AND SIGN OF SECOND + XOR D,C ;GET SIGN OF RESULT + JMP RETSNG ;RETURN IT +MULBER: ERROR+RTB ;RESULT TOO BIG + +;LINEARIZE TO NUMBERS INTO NUM1 AND NUM2 PUT THE SIGNS INTO NUM1S AND NUM2S +STNG2U: MOV #NUM1,A ;GET POINTER TO THE FIRST NUMBER + JSR PC,LINEAR + MOV B,NUM1S + MOV A,NUM1E ;GET THE END OF THE FIRST NUMBER + MOV #NUM2,A ;GET POINTER TO THE SECOND NUMBER + JSR PC,LINEAR + MOV B,NUM2S + MOV A,NUM2E + RTS PC + + +;;; DIVIDE TWO STRING NUMBERS +STNGDV: JSR PC,STNG2U ;GET DIVIDEND IN NUM1 DIVISOR IN NUM2 + MOV #NUM1,A ;FIND FIRST NON ZERO DIGIT IN DIVISOR +1$: TSTB (A)+ + BNE SDIV1 + CMP A,NUM1E ;BE SURE WE DONT RUN OFF THE NUMBER + BLO 1$ ;STILL OKAY +SDIVER: ERROR+RTB ;RESULT TOO BIG +SDIV1: MOV #TMPBLK,B ;GET POINTER TO TEMPORARY AREA + TSTB -(A) ;BACK UP POINTER + MOV A,(B)+ ;POINTER TO DIVISOR + SUB NUM1E,A ;GET LENGTH OF IT + NEG A + MOV A,(B)+ ;AND STORE IT + MOV #NUM2,C ;GET POINTER TO THE DIVIDEND +1$: TSTB (C)+ ;STRIP OFF LEADING ZEROS + BNE 2$ ;FOUND A DIGIT + CMP C,NUM2E ;AT END YET? + BLO 1$ ;NO, TRY AGAIN +2$: TSTB -(C) ;BACK UP POINTER + MOV C,(B)+ ;POINTER TO THE DIVIDEND + ADD C,A ;START WITH THE TRIAL DIVIDEND EQUAL IN LENGTH TO DIVISOR + MOV A,(B)+ ;STORE IT + CLR (B)+ ;CLEAR FLAG SAYING THAT DIVIDEND IS BIGGER THAN DIVISOR + MOV #NUM3+1,NUM3E ;LEAVE A DIGIT ON TOP TO BE ZERO IN CASE NO DIVIDES WORK + MOV NUM3E,(B) ;START PUTTING DIGITS AT THE BOTTOM OF NUM3 +;;; HERE TMPBLK IS SET UP AS FOLLOWS: +;;; TMPBLK: POINTER TO THE DIVISOR (NON-ZERO DIGIT) +;;; DIVISOR LENGTH +;;; POINTER TO THE START OF THE DIVIDEND WE ARE TRYING TO GET QUOTIENT FOR +;;; POINTER TO THE END OF THE DIVIDEND WE ARE TRYING TO GET QUOTIENT FOR +;;; FLAG SAYING THAT DIVIDEND LENGTH IS > DIVISOR LENGTH +;;; OUTPUT POINTER +DIVLOP: CMP TMPBLK+6,NUM2E ;DONE WITH THE DIVIDEND YET? + BHI DIVDON ;YES + JSR PC,DIVDGT ;GET A DIGIT OF THE QUOTIENT + MOVB A,@TMPBLK+12 ;AND IN OUTPUT DATA + BEQ 2$ ;IF ZERO, DONT MOVE THE START POINTER + TSTB @TMPBLK+4 ;IS THIS DIGIT 0? + BNE 2$ ;WELL, NO, SO LEAVE IT THERE FOR NEXT TIME + INC TMPBLK+4 ;WE ARE DONE WITH THAT DIGIT FOR SURE +1$: INC TMPBLK+6 ;ADD ANOTHER DIGIT ON THE RIGHT SIDE + INC TMPBLK+12 ;POINT TO NEXT SLOT + BR DIVLOP ;DO IT AGAIN +2$: INC TMPBLK+10 ;SET FLAG SAYING THAT DIVIDEND IS BIGGER + BR 1$ ;AND LOOP BACK +DIVDON: MOV NUM1S,C ;GET THE SIGN OF THE DIVIDEND + MOV NUM2S,D ;AND SIGN OF DIVISOR + XOR D,C ;GET SIGN OF RESULT + MOV TMPBLK+12,B ;GET POINTER TO THE END OF THE NUMBER + MOV #NUM3,A ;AND POINTER TO THE START OF THE NUMBER + JMP RETSNG ;RETURN THE NUMBER + +;;; DIVIDE UTILITIES +;;; DIVDGT GETS A QUOTIENT DIGIT +DIVDGT: JSR PC,DIVEST ;ESTIMATE THE DIGIT + SPUSH A ;SAVE THE DIGIT + BEQ 1$ ;IT IS ZERO, SO SKIP THE MUL AND SUBTRACTION + MOV A,C ;COPY IT + JSR PC,DIVMUL ;MAKE DIVIDEND = DIVIDEND - DIVISOR*DIGIT +1$: JSR PC,DIVCMP ;SEE IF ANOTHER DIVISOR FITS IN CURRENT PIECE OF DIVIDEND + BEQ 2$ ;YEP, SUBTRACT IT OFF + TST TMPBLK+10 ;ARE WE CURRENTLY ONE DIGIT LONGER? + BEQ 4$ ;NO, JUST RETURN + MOV TMPBLK+4,C ;GET POINTER TO THE DIVIDEND + TSTB (C)+ ;SKIP IT, SHOULD BE ZERO + TSTB (C) ;IS THE NEXT DIGIT 0? + BNE 4$ ;NO, STILL WILL BE ONE LONGER NEXT TIME + CLR TMPBLK+10 ;OTHERWISE CLEAR FLAG, AND INCREMENT START + INC TMPBLK+4 ;SO THAT WE WIN NEXT LEVEL UP +4$: SPOP A ;GET BACK DIGIT + RTS PC ;AND RETURN +2$: INC (P) ;QUOTIENT DIGIT IS REALLY ONE BIGGER + MOV #1,C ;MULTIPLY BY 1 + JSR PC,DIVMUL ;SUBTRACT OFF DIVISOR AGAIN + BR 1$ ;AND TRY AGAIN + +;;; DIVEST CONSERVATIVELY ESTIMATES THE QUOTIENT DIGIT +DIVEST: MOV TMPBLK+4,C ;GET POINTER TO THE HIGH ORDER DIGITS OF THE DIVIDEND PIECE + TST TMPBLK+10 ;IS THE DIVIDEND LONGER? + BNE DIVES1 ;YES, SO TAKE THE NEXT TWO DIGITS FROM DIVIDEND + MOVB (C)+,B ;GET THE FIRST DIGIT +;;; HERE THE FIRST DIGIT OR TWO OF DIVIDEND IS IN B, WE DIVIDE BY A ROUNDED UP DIVISOR DIGIT +DIVES2: MOVB @TMPBLK,C ;GET FIRST DIGIT OF DIVISOR + INC C ;ROUND UP + CLR A ;FOR THE DIVIDE + DIV C,A ;GET QUOTIENT IN A FOR TRIAL + RTS PC ;AND RETURN +;;; HERE THE DIVIDEND PIECE IS ONE LONGER THAN THE DIVISOR, SO TAKE THE FIRST TWO DIGITS +DIVES1: MOVB (C)+,B ;GET THE FIRST + MUL #10.,B ;AND ADD IN THE SECOND + MOVB (C)+,A + ADD A,B + BR DIVES2 ;NOW CONTINUE AS NORMAL + +;;; DIVCMP SEES IF ANOTHER DIVISOR WILL FIT IN THE DIVIDEND PIECE WE ARE WORKING ON +DIVCMP: MOV TMPBLK+4,A ;GET POINTER TO THE DIVIDEND PIECE + MOV TMPBLK,B ;GET POINTER TO THE DIVISOR + MOV TMPBLK+2,C ;GET COUNT OF THE DIVISOR + TST TMPBLK+10 ;IS THE DIVIDEND PIECE ONE LONGER THAN THE DIVISOR + BNE DVCMP1 ;YES, COMPARE SPECIALLY +DVCMPL: CMPB (A)+,(B)+ ;COMPARE THE DIVIDEND TO THE DIVISOR + BGT DVCMPF ;FAIL IF THE DIVIDEND IS BIGGER + BLT DVCMPS ;SUCCEED IF IT IS SMALLER + SOB C,DVCMPL ;IF EQUAL KEEP TRYING +;;; IF EXACTLY EQUAL, FAIL +DVCMPF: SEZ +DVCMPS: RTS PC +DVCMP1: TSTB (A)+ ;IF THE FIRST DIGIT ISNT ZERO, THEN WE FAIL + BNE DVCMPF + BR DVCMPL ;IF IT IS, COMPARE THE REST OF THE NUMBER + +;;; DIVMUL MULTIPLIES THE DIVISOR BY A DIGIT, THEN SUBTRACTS IT FROM A PIECE OF THE +;;; DIVIDEND +DIVMUL: CLR A ;CARRY HERE + MOV TMPBLK+2,D ;LENGTH OF THE DIVISOR + MOV D,E ;COPY IT + ADD TMPBLK,E ;AND GET POINTER TO THE END OF THE DIVISOR + MOV TMPBLK+6,F ;WHERE TO START SUBTRACTING FROM (END OF THE DIVISOR PIECE) +DVMULL: MOVB -(E),B ;MUL -(E),C => B + MUL C,B + SUB B,A ;THIS IS THE CARRY (WILL ALWAYS BE NEGATIVE) +DVMUL1: MOVB -(F),B ;GET THE DIGIT TO SUBTRACT IT FROM + ADD A,B ;WELL A IS NEGATIVE SO THIS IS A SUBTRACT + SXT A ;FOR DIVIDE + DIV #10.,A ;GET THE DIGIT AND THE CARRY + TST B ;IS THE REMAINDER NEGATIVE? + BGE 1$ ;NO, SO IT IS OKAY, THERE CAN'T BE A CARRY + ADD #10.,B ;GET THE DIGIT BY 9'S COMPLEMENT + DEC A ;CARRY IS ONE MORE NEGATIVE +1$: MOVB B,(F) ;STORE BACK THE DIGIT + SOB D,DVMULL ;GO UNTIL WE ARE DONE WITH THE DIVISOR + TST A ;CARRY? + BNE 2$ ;YES, WE WILL HAVE TO CONTINUE + RTS PC +2$: CLR B ;THIS IS THE SUBTRAHEND + INC D ;TO FAKE OUT THE SOB + BR DVMUL1 ;GO BACK AN PROPOGATE CARRY + + .GLOBL MXNUML +;LINEARIZE A NUMBER OFF THE S PDL, A POINTS TO AREA, A IS RETURNED POINTING +;PAST THE END OF NUMBER, B IS THE SIGN OF THE NUMBER 0=POS. 1=NEG +LINEAR: CLR (A)+ ;CLEAR THE FIRST TWO DIGITS + CLR -(P) ;THE SIGN FLAG + SPUSH A ;SAVE THE REGS + MOV @S,B ;GET THE ARGUMENT + MOV #LSTR,A ;CONVERT IT TO LSTR + JSR PC,CONVERT ;TRY AND CONVERT + BNE 1$ + ERROR+WTAB ;WRONG TYPE OF ARG +1$: SPOP E ;GET BACK POINTER + MOV #MXNUML,F ;COUNTER FOR THE MAXIMUM LENGTH OF NUMBERS + JSR PC,INSTR ;START THE STRING + BEQ LNRDON ;NO STRING WE MUST BE DONE + CLR B ;LEADING ZERO FLAG + CMP D,#'+ ;WAS IT PLUS? + BEQ LNRLOP ;YES, JUST LOOP + CMP D,#'- ;WAS IT MINUS + BNE LNRLP1 ;NO, TREAT IT LIKE A NUMBER + COM 2(P) ;SET SIGN FLAG +LNRLOP: JSR PC,@(SP)+ ;CALL COROUTINE TO GET CHARACTER + BEQ LNRDON ;WE ARE DONE NOW +LNRLP1: SUB #'0,D ;CONVERT IT FROM ASCII + BEQ 3$ ;IT IS ZERO, CHECK LEADING 0 FLAG + BLT 1$ ;ERROR IF NOT A DIGIT + CMP #'9-'0,D ;IS IT TO BIG + BHIS 2$ ;IT IS A DIGIT +1$: ERROR+WTA ;WRONG ARGUMENT +3$: TST B ;IGNORE ZEROS? + BEQ LNRLOP ;YES, IGNORE THE ZEROS +2$: INC B ;WE ARE PLACING A DIGIT, NO LONGER IGNORE ZEROS + MOVB D,(E)+ ;PUT THE BYTE AWAY + SOB F,LNRLOP ;DO FOR ALL THE BYTES + JSR PC,@(SP)+ ;SEE IF THERE IS ANOTHER NUMBER + BEQ LNRDON ;NOPE, WIN + ERROR+RTB ;NUMBER TO BIG +LNRDON: SPOP B ;GET BACK THE SIGN FLAG + ADD #2,S ;POP OFF THE ARGUMENT + MOV E,A ;PUT BACK POINTER INTO A + RTS PC + +; GET THE 9'S COMPLEMENT OF A NUMBER WHOSE END IS POINTED TO BY B, LENGTH IN A +COMPL: SPUSH A + MOV #1,C ;ADD THE CARRY IN +COMPLP: MOVB -(B),D ;GET THE NUMBER TO CONVERT + SUB #9.,D ;COMPLEMENT IT + NEG D + ADD C,D ;ADD THE CARRY + CLR C ;CLEAR THE CARRY + CMP D,#10. ;IS IT TOO BIG? + BLT 1$ ;NO, CLEAR TEH CARRY AND GO AWAY + SUB #10.,D ;MAKE IT SMALL AGAIN + INC C +1$: MOVB D,(B) ;PUT BACK COMPLEMENTED BYTE + SOB A,COMPLP ;GO BACK FOR ALL THE BYTES + SPOP A + RTS PC +.ENDC + +.SBTTL LIST AND WORD OPERATIONS +SENTEN: +SENT.: CLR C + TST D +SENT.1: BLE SENT.R ;RETURN + MOV @S,B ;ARGUMENT. LEAVE ON S-PDL FOR GARBGE COLLECTOR + MOV B,A + BIC #7777,A ;LEAVE ONLY DATA TYPE + CMP #LIST,A + BEQ SENT.S ;ARG IS LIST + CMP #ATOM,A + BNE SENT.2 ;ARG IS LSTR OR INUM + +;ARG IS AN ATOM +SENT.A: JSR PC,.LOAD ;CONVERT ATOM TO LSTR + MOV #LSTR,A + +SENT.2: BIS C,A ;C POINTS TO PREVIOUS STUFF OF SENTENCE + JSR PC,GRBAD + +SENT.3: MOV C,GCPREV ;POINTER TO PREVIOUS STUFF OF SENTENCE + BIS #LIST,GCPREV ;GARBAGE COLLECTOR NEEDS RIGHT DATA TYPE +SENT.4: JSR PC,SPOPT ;POP S + DEC D ;COUNTER + BR SENT.1 + +SENT.S: BIT #7777,B ;ARGUMENT IS A LIST + BEQ SENT.4 ;EMPTY + TST C ;0 IF FIRST TIME CALLED + BEQ SENS.1 ;NO NEED TO COPY +;SECOND OR LATER TIME THROUGH +SENS.2: JSR PC,COPYL ;COPY LIST. RETURN POINTER IN B + BIC #170000,GCPREV ;CLEAR DATA TYPE + BIS GCPREV,A ;POINTER TO PREVIOUS STUFF + JSR PC,.STP1 ;C STILL POINTS TO LAST NODE COPIED +SENS.1: BIC #170000,B ;LEAVE POINTER ONLY + MOV B,C + BR SENT.3 + +;RETURN. POINTER TO SENTENCE IN C +SENT.R: BIS #LIST,C + CLR GCPREV + PUSHS C + CLZ + RTS PC + + +.GLOBL GCP1,UEL ;025 + +LIST.P: + SAVE #ORTC +LIST1: CLR C +LIST.1: DEC D ;COUNT + BLT LIST.9 ;DONE + MOV @S,B + MOV B,A + BIC #7777,A ;LEAVE DATA TYPE ONLY +LIST.2: BIS C,A ;POINTER TO REST OF LIST + JSR PC,GRBAD + MOV C,GCPREV ;PROTECT FROM GARBAGE COLLECTOR + BIS #LIST,GCPREV ;GAR. COLL. NEEDS RIGHT DATA TYPE + JSR PC,SPOPT + BR LIST.1 ;GET NEXT ARG + +LIST.9: CLR GCPREV + BIS #LIST,C + RTS PC + +FPUT: + CLR F + BR LPUT69 +LPUT: + MOV #,F +LPUT69: SAVE #ORTC + DEC D + BGT 1$ + ERROR+UEL ;NEED AT LEAST 2 ARGS +1$: JSR PC,GLWARG + BEQ 2$ ;LIST + ERROR+WTA ;FIRST ARG MUST BE LIST +2$: ADD F,PC ;CHOOSE BETWEEN LPUT AND FPUT + +FPUT1: MOV B,A ;POINTS TO ARG + BIC #170000,A ;CLEAR DATA TYPE + JSR PC,SPOPT + MOV @S,B ;FIRST ELEMENT TO BE PUT + MOV B,C + BIC #7777,C ;THIS DATA TYPE WILL BE SET INTO A + DEC D + BR LIST.2 + +LPUT1: JSR PC,COPYL ;COPY LIST. RETURN PTR IN B + MOV B,GCP1 + JSR PC,SPOPT ;POP 1ST ARG + JSR PC,LIST1 ;LIST REST OF ARGS + TST F + BEQ LPUT2 + BIC #170000,C ;POINTER TO THAT LIST + MOV C,D ;SAVE IT + MOV F,C ;POINTER TO LAST NODE OF COPIED LIST + JSR PC,.LDP1 + BIS D,A ;JOIN COPIED LIST TO LIST OF ARGS + JSR PC,.STP1 + MOV GCP1,C +LPUT2: CLR GCP1 + RTS PC + + +WORD: CLR GCPREV ;USED AS A FLAG LATER + CLR C + TST D +WORD.1: BLE WORDR + MOV @S,B ;GET ARG, BUT LEAVE ON STACK + +.IFZ FPPF + CMP B,#LNUM ;IS ARG NUMBER? + BLO WORD.2 + CMP B,# + BLO WORD.N ;NUMBER +.IFF + MOV B,A ;DOES B POINT TO INUM OR FNUM + BIC #170000,A + CMP #INUM,A + BEQ WORD.N + CMP #FNUM,A + BEQ WORD.N +.ENDC + +WORD.2: MOV #LSTR,A + JSR PC,CONVERT + BNE 1$ + ERROR+WTAB +1$: BIT #7777,B ;IS ARG THE EMPTY WORD + BEQ WORD.4 ;YES + + TST GCPREV ;IS 0 FIRST TIME THROUGH + BEQ WORD.3 + +;SECOND OR LATER ARG + JSR PC,CPYSTR ;COPY STRING +WORD.6: JSR PC,.LDP1 ;LAST NODE OF COPIED STRING + BIC #170000,GCPREV ;CLEAR DATA TYPE + BIS GCPREV,A ;BIS POINTER TO PREVIOUS STUFF + JSR PC,.STP1 ;STORE BACK + +WORD.3: BIC #170000,B + BIS #LSTR,B ;GAR. COLL. NEEDS RIGHT DATA TYPE + MOV B,GCPREV ;POINTER TO PREVIOUS STUFF +WORD.4: JSR PC,SPOPT ;POP S + DEC D + BR WORD.1 + +;ARGUMENT IS NUMBER. CONVERT TO STRING +WORD.N: +.IFZ FPPF + JSR PC,.CINLS +.IFF + + +.CLNLS: MOV B,A + BIC #170000,A + CMP #INUM,A + BEQ .CLNL1 + JMP .CINLS +.CLNL1: JMP .CFNLS +.ENDC + TST GCPREV ;IS 0 FIRST TIME THROUGH + BEQ WORD.3 ;IS FIRST ARG + BR WORD.6 ;SECOND OR LATER, BUT DON'T RECOPY!! + +;RETURN +WORDR: MOV GCPREV,C + BIS #LSTR,C + CLR GCPREV + JMP ORTC + + +MEMBER: JSR PC,GLWARG ;GET A LIST OR WORD ARGUMENT + BNE MEM.WD ;ITS A WORD + MOV B,GCPREV ;PROTECT THIS FROM THE GC + SAVE B ;SAVE POINTER TO NEXT NODE + ADD #2,S ;AND POP IT OFF + JSR PC,GLWARG ;GET A LIST OR WORD ARGUMENT + MOV B,@S ;PROTECT THE ARGUMENT +MEMLP: SPOP A ;GET POINTER TO THE THING WE ARE LOOKING FOR + BIT #7777,A ;IS IT EMPTY + BEQ MEMFLS ;YES, RETURN IT + MOV A,GCPREV ;SAVE IT + JSR PC,.LOADA ;LOAD IT INTO A,,B + SPUSH A ;SAVE POINTER TO BUTFIRST + MOV @S,C ;GET THE OBJECT TO COMPARE AGAINS + JSR PC,EQUAL1 ;ARE THEY EQUAL? + BEQ MEMLP ;NOT EQUAL, TRY THE NEXT ELEMENT + TST (P)+ + MOV GCPREV,A ;GET BACK THE LIST TO RETURN +MEMFLS: BIC #170000,A ;CLEAR IT'S TYPE + BIS #LIST,A ;IT'S A LIST + MOV A,@S ;AND RETURN +MEMRT: CLR GCPREV ;NO GC PROTECTION ANY MORE + CLZ ;RETURN A VALUE + RTS PC +MEMWDF: MOV #LSTR,@S ;RETURN EMPTYP WORD + BR MEMRT ;AND RETURN +;HERE FIND THE CHARACTER IN THE WORD THAT IS EQ TO THE FIRST CHAR OF THE SEARCHED +;FOR WORD +MEM.WD: MOV B,GCPREV ;SAVE THE WORD TO SEARCH THROUGH + ADD #2,S ;POP IT OFF + JSR PC,GLWARG ;GET THE OBJECT TO LOOK FOR + BEQ MEMWDF ;ITS A LIST, CANT SEARCH FOR THAT IN A WORD!! + JSR PC,INSTR ;IS THERE A CHARACTER? + BEQ MEMWDF ;NO, JUST RETURN EMPTYP WORD + TST (P)+ ;POP OFF CO-ROUTINE LINKAGE + MOV D,F ;SAVE THE CHARACTER TO LOOK FOR, AND DESTROY CO-ROUTINE + MOV GCPREV,B ;GET BACK POINTER TO THE WROD TO SEARCH FOR + MOV #INSTR,-(P) ;CALL THE SUBROUTINE TRICKILY +MWDLP: JSR PC,@(P)+ ;GET THE NEXT CHARACTER + BEQ MEMWDF ;NO MORE, RETURN EMPTY WORD + CMP D,F ;ARE THEY EQUAL? + BNE MWDLP ;NO, CHECK THE NEXT CHARACTER + TST (P)+ ;POP OFF CO-ROUTINE + MOV A,B ;THE REST OF THIS WORD (INCLUDING THE CHAR IN D) + MOV C,A ;THE POINTER TO THE REST OF THE WORD + JSR PC,GRBAD ;GET A NODE WITH THEM IN IT + BIC #170000,C ;CLEAR THE TYPE + BIS #LSTR,C ;MAKE IT AN LSTR + MOV C,@S ;AND RETURN IT + BR MEMRT + +FIRST: + JSR PC,GLWANE + BEQ F.SENT ;ARG IS SENTENCE + +;ARG IS WORD + JSR PC,INSTR ;RETURN ONE CHAR IN D + BNE F.WTA9 ;FOUND A CHAR +F.WTA: ERROR+WTA ;NO CHARS IN STRING +F.WTA9: TST (SP)+ ;POP OFF CO-ROUTINE LINK + MOV D,B +F.STOR: CLR F + JSR PC,ACTSTO ;STORE THE CHAR. + POPS C + BIC #170000,C + BIS #LSTR,C ;POINTER TO THE NODE OF THE CHAR + JMP ORTNC + +F.SENT: MOV B,C + JSR PC,.LDP2 + JMP ORTNA + + +BUTFIRST: + JSR PC,GLWANE + BEQ BF.SEN + +;ARG IS WORD + JSR PC,INSTR ;RETURN ONE CHAR + BEQ F.WTA ;NO CHARS IN STRING + TST (SP)+ +;A CONTAINS FIRST 2 CHARS OF THE STRING +;BUT IT MAY ONLY HAVE ONE. + BIT #377,A ;IS TOP CHAR OF A 0? + BEQ BF.W1 + BIT #77400,A + BEQ BF.W1 ;YES. ONLY ONE CHAR IN A + CLRB A ;KILL THE FIRST CHAR + MOV A,B + MOV C,A ;POINTER TO REST + JSR PC,GRBAD +BF.W1: BIC #170000,C + BIS #LSTR,C + JMP ORTNC + +;ARG IS SENTENCE +BF.SEN: MOV B,C + JSR PC,.LDP1 ;POINTER TO REST OF SENTENCE + BIC #170000,A ;LEAVE ONLY POINTER + BIS #SENT,A + JMP ORTNA + + +LAST: + JSR PC,GLWANE + BEQ L.SENT ;ARG IS SENTENCE + +;ARG IS WORD + MOV B,C + SPUSH #INSTR1 ;ADDRESS OF CO-ROUTINE + CLR D +L.W1: MOV D,B ;SAVE LAST CHAR + JSR PC,@(SP)+ ;RETURNS CHAR IN D + BNE L.W1 ;FOUND ONE + TST B ;STRING DONE + BNE F.STOR ;STORE THE CHAR AND RETURN + ERROR+WTA ;NO CHARS FOUND + +L.SEN1: MOV A,B +;ARG IS SENTENCE +L.SENT: JSR PC,.LOAD + BIT #7777,A ;LAST NODE OF SENTENCE YET? + BNE L.SEN1 + +L.SRET: JMP ORTNB + + +BUTLAS: JSR PC,GLWANE + BEQ BL.SEN ;ARG IS A SENTENCE + +;ARG IS A WORD + JSR PC,CPYSTR ;COPY STRING. + JSR PC,.LDP2 ;LAST NODE OF NEW STRING + SWAB A + BNE 2$ ;THE LAST CHARACTER IS REALLY THERE + CMP B,C ;IS THERE ONLY ONE NODE + BNE 1$ ;MORE TAN ONE NODE + CLR B ;ANSWER IS EMPTY WORD + BR 3$ +1$: MOV C,F ;SAVE THIS NODE POINTER + SPUSHS B + MOV B,C ;POINTER TO HEAD OF LIST +4$: JSR PC,.LOADC ;LAOD THE NODE + BIC #170000,A ;FLUSH TYPE + CMP A,F ;DOES IT POINT TO ME? + BEQ 5$ + MOV A,C + BR 4$ +5$: MOV #SSTR,A + JSR PC,.STORE + SPOPS B + BR 3$ +2$: CLRB A ;CLEAR LAST CHAR + JSR PC,.STP2 ;STORE NODE BACK +3$: BIS #LSTR,B ;POINTER TO THE WORD + JMP ORTNB + +;ARG IS A SENTENCE +BL.SEN: JSR PC,COPYL ;COPY LIST + MOV E,C ;POINTS TO NEXT TO LAST NODE + BEQ BL.SR ;ANSWER IS EMPTY + JSR PC,.LDP1 + BIC #7777,A + JSR PC,.STP1 + MOV B,C +BL.SR: BIS #LIST,C + JMP ORTNC + + +.GLOBL LSTRCV ;031 +;INPUT IS NUMBER. OUTPUT IS THE CHARACTER CORRESPONDING TO THAT NUMBER + +CHAR: JSR PC,G1IARG ;B,,C _ NUMBER + MOV C,B + BIC #177400,B + MOV #SSTR,A + JSR PC,GRBAD + BIS #LSTR,C + JMP ORTC + +;INPUT IS WORD, OUTPUT IS # OF FIRST CHAR +ASCI: JSR PC,LSTRCV ;CONVERT TO LSTR + JSR PC,.LOAD ;GET THE FIRST NODE + BIC #177400,B ;GET A 8 BIT CHARACTER + JMP R1NARG + +COUNT: + JSR PC,GLWARG + BEQ CT.SEN + +;ARG IS WORD + MOV B,C + CLR B + MOV #INSTR1,-(SP) ;ADDRESS OF A CO-ROUTINE +CT.W1: INC B ;INCREMENT COUNTER + JSR PC,@(SP)+ ;RETURNS CHAR IN B + BNE CT.W1 + DEC B ;WHEN RETURNS HERE, NO MORE CHARS +CT.ORT: POPS C + JMP R1NARG ;C IS A THROW-AWAY + +;ARG WAS A SENTENCE +CT.SEN: MOV B,C + JSR PC,CLE ;RETURNS NUMBER OF LIST ELEMENTS IN B + BR CT.ORT + + +;COPY LIST. +; CALL WITH B POINTING TO LIST +; RETURNS B POIOTING TO NEW LIST, C POINTING TO LAST NODE +COPYL: CLR E ;WILL POINT TO 2ND NODE FROM LAST + CLR F + BIT #7777,B + BEQ COPYR1 +COPYL1: BIT #7777,B + BEQ COPYLR ;DONE + JSR PC,.LOAD + MOV F,E ;LISTB PLACES LAST NODE PTR INTO F + JSR PC,LISTB + MOV A,B + BR COPYL1 + +COPYLR: MOV F,C ;LISTB KEEPS PTR TO LAST NODE OF LIST IN F + POPS B ;LISTB KEEPS POINTER TO NEW LIST ON S. +COPYR1: RTS PC + + +;COPY STRING +;CALL WITH B POINTING TO STRING TO BE COPIED, +;ASSUMES THAT INPUT STRING HAS BEEN GARBAGE COLLECT PROTECTED ALREAEDY +;B POINTS TO FIRST NODE OF NEW STRING, C POINTS TO LAST + +CPYSTR: MOV #INSTR,A + MOV D,-(SP) + MOV E,-(SP) + MOV F,-(SP) + + MOV A,-(SP) ;ADDRESS OF INPUT STRING ROUTINE + CLR F + +OUTSTR: JSR PC,@(SP)+ ;CALL INPUT STRING CO-ROUTINE + BEQ OSTRE1 ;INPUT STRING DONE + +OSTR1: MOV D,B ;SAVE CHARACTER + JSR PC,@(SP)+ ;CALL INPUT STRING CO-ROUTINE + BEQ OSTRE2 ;INPUT STRING DONE + +OSTR2: SPUSH A ;SAVE REGISTERS USED BY INPUT STRING + SWAB D + BIS D,B ;BIS SECOND CHARACTER + JSR PC,ACTSTO ;ACTUAL STORE + SPOP A + BR OUTSTR + +;INPUT STRING HAS ENDED +OSTRE2: JSR PC,ACTSTO ;STORE CHAR IN B +OSTRE1: POPS B ;POINTER TO FIRST NODE OF STRING + MOV F,C ;POINTER TO LAST NODE + BIC #170000,B + BIC #170000,C +.RDEF: CLR GCP1 + MOV (SP)+,F + MOV (SP)+,E + MOV (SP)+,D + SEZ +OSTRR: RTS PC + + +;ACTUALLY STORE OUTPUT NODE +ACTSTO: MOV #SSTR,A + JMP LISTB + + +;INPUT STRING +;A CO-ROUTINE THAT HANDS BACK A CHARACTER IN BOTTOM BYTE OF D +;DOES RTS PC WHEN INPUT STRING FINISHED + +INSTR: MOV B,C +INSTR1: BIT #7777,C + BEQ OSTRR ;RTS PC + JSR PC,.LDP2I + MOVB A,D + BIC #177400,D ;CLEAR TOP BYTE + BEQ INSTR2 ;NULL CHAR + JSR PC,@(SP)+ ;RETURN TO CO-ROUTINE + +INSTR2: CLRB A + SWAB A + MOV A,D + BIC #177400,D + BEQ INSTR1 ;NULL CHAR + JSR PC,@(SP)+ ;RETURN TO CO-ROUTINE + BR INSTR1 + + +;LIKE INSTR, EXCEPT GETS CHAR FROM TEXT STRING (NOT NODE SPACE) +;NOTE -- ENTER AT INTXT +INTXT0: JSR PC,@(P)+ +INTXT: MOVB (C)+,D + BNE INTXT0 ;BR IF NOT END OF TEXT + RTS PC + +.GLOBL HNV,TOPS1 ;034 +.GLOBL FLAGS2,NBKTS ;035 +MAKE: +MMAKE9: POPS TOPS ;PUT VALUE INTO TOPS + MOV @S,B + MOV B,A + BIC #7777,A + CMP #ATOM,A ;IS TYPE ATOM? + BNE MAKE2 +MAKE4: MOV #VBIND,A ;YES< SET VARIABLE BINDING? + JSR PC,.BIND +MAKE1: POPS A + JMP CLRTP1 + +MAKE2: CMP #LSTR,A + BEQ MAKE3 +MAKE5: ERROR+WTAB ;WRONG TYPE OF ARG +MAKE3: BIT #7777,B + BEQ MAKE5 + MOV TOPS,@S + MOV B,TOPS ;FOR .INTRN + JSR PC,UINTRN ;.INTRN FOR STRINGS THAT MAY INCLUDE NULL CHARS + MOV @S,TOPS + BIS #ATOM,B + MOV B,TOPS1 + BR MAKE4 + +DOTS: JSR PC,GETVAL ;GET VALUE IF IT HAS ONE + BNE 1$ + ERROR+HNV ;HAS NO VALUE +1$: PUSHS B + CLR TOPS + CLZ + RTS PC + +THINGP: JSR PC,GETVAL ;DOES IT HAVE A VALUE? + BEQ THNGPF ;NO + JMP RTTRUE +THNGPF: JMP RTFALS + +GETVAL: JSR PC,GUOEB ;GET UOE PTR FROM S INTO B + BEQ GETVA1 + MOV #VBIND,A + JSR PC,.BINDL + BEQ GETVA1 + TST B +GETVA1: RTS PC ;HAS NO VALUE (UNBOUND LOCAL) + +GUOEB: POPS B ;GET UOE OR LSTR IN B FROM S + MOV B,A ;SKIP IF UOE + BIT #7777,A ;EMPTY? + BEQ GUOE5 + BIC #7777,A + CMP #ATOM,A + BEQ GUOE1 + CMP #LSTR,A + BEQ GUOE2 +GUOE5: ERROR+WTAB ;.(B). ISWRONG TYPE OF ARG +GUOE2: MOV B,TOPS + JMP UOBSCH ;.OBSCH FOR STRINGS THAT HAVE NULL CHARS +GUOE1: CLZ + RTS PC + ;PRINT TOP (C) THINGS ON S +FPRINT: INC NBKTS ;PRINTS OUTER [,]'S +PRINT: SAVE D + JSR PC,REVS ;DOESNT " + POP C + JSR PC,TYPE1 + JSR PC,.CRLF + SEZ + RTS PC + +TYPE: SAVE D + JSR PC,REVS + POP C + JSR PC,TYPE1 ;PRINT WITHOUT CRLF AT END + SEZ + RTS PC + +TYPE1: DEC C + BLT 1$ + BIS #DPQF+CPTBF,FLAGS2 ;DONT PRINT QUOTE BEFORE STRINGS + ;BUT DO PRINT % AS BLANK + JSR PC,PRS1 + POPS A + BR TYPE1 +1$: BIC #DPQF+CPTBF,FLAGS2 + RTS PC + +.IFNZ LSIHAK +LOAD: +.IFZ DMPCAS + MOV #1,D ;TO LOGO. THE SITS RTN WILL THEN INPUT THE CONTENTS + JSR PC,SETTIM + JSR PC,TYO ;OF THE FILE TO LOGO + JSR PC,RESTTY + MOV #1,D ;ONE THING TO PRINT + JSR PC,TYPE1 + JSR PC,.CRLF +.IFF +STLANC +ENGINS > +ENDENG +FRINS > +ENDLAN +.ENDC + JSR PC,LSTIG ;SET TTY INPUT TO IMAGE WITH BIG BUFFER + CLR LSILSC ;CLEAR LOST CAHRS COUNT + MOV PC,REDFLG + SEZ + RTS PC + +ENDFIL: JSR PC,LSTRES ;RESTORE REAL BUFFERS + CLR REDFLG + TST LSILSC + BEQ 1$ + PRTXT + CLR LSILSC +1$: SEZ + RTS PC + +DUMP: +STLANC +ENGINS > +ENDENG +FRINS > +ENDLAN + JSR PC,ONETYI + MOV PC,WRTFLG + JSR PC,SETTIM ;SET TTY TO IMAGE MODE + JSR PC,SHOWAL +STLANC +ENGINS > +ENGINS > +ENDENG +FRINS > +FRINS > +ENDLAN + PRCR + JSR PC,ONETYI + JSR PC,RESTTY + CLR WRTFLG + SEZ + RTS PC +.ENDC + + .SBTTL PREDICATES, IF, UNTIL AND TEST + +EQUAL: MOV S,F + MOV (F)+,B ;ARG1. LEAVE ON STACK FOR GC PROTECTION + MOV (F),C ;ARG2 + JSR PC,EQUAL1 + BEQ EQ.F ;RETURNS HERE IF FALSE + ADD #4,S + JMP RTTRUE +EQ.F: ADD #4,S + JMP RTFALS + + +;COMPARE THE DATA ITEM POINTED TO BY B WITH +;THE DATA ITEM POINTED TO BY C. +;SKIP IF THEY ARE EQUAL +EQUAL1: CMP B,C ;ARE THEY EQ? + BEQ EQTRUE ;WONDERFULLY SIMPLE CASE + MOV #7777,E ;AN OFT-USED CONSTANT + MOV B,A + MOV C,D + BIC E,A + BIC E,D + CMP A,D + BNE WEQUAL + CMP #LIST,A + BNE WEQUAL +EQ.LST: BIC #170000,B + BIC #170000,C + CMP B,C + BEQ EQTRUE + TST B + BEQ EQFALS + TST C + BEQ EQFALS + JSR PC,.LOAD + PUSH A + JSR PC,.LDP2I + SPUSH C + MOV A,C + JSR PC,EQUAL1 + BEQ EQ.FF + POP B + SPOP C + BR EQ.LST + +EQ.FF: CMP (SP)+,(SP)+ ;POP OFF THE POINTERS TO THE BF'S + JSR PC,PPOPT + SEZ + RTS PC + + ;COMPARE TWO WORDS +.GLOBL EXCH1,GCP2 ;039 +.GLOBL FALSE,TRUE ;040 + +.IFZ FPPF + +WEQUAL: MOV #INUM,A + JSR PC,CONVERT ;TRY CONVERTING ARG TO INUM + BEQ EQ.STR ;NOT NUMERIC + EXCH B,C + JSR PC,CONVERT ;TRY CONVERTING 2ND ARG + BEQ EQFALS ;NOT NUMERIC + JSR PC,.LOAD ;A,,B HAVE NUMBER + MOV A,D + MOV B,F + JSR PC,.LOADC + CMP A,D ;COMPARE 2 INTEGERS + BNE EQFALS + CMP B,F + BNE EQFALS + BR EQTRUE +.IFF + +WEQUAL: JSR PC,G1NUMS ;IS IT A NUMBER? + BEQ EQ.STR + LDD FA,FB ;IT WAS SO SAVE IT + MOV C,B ;IS THE SECOND A NUM? + JSR PC,G1NUMS + BEQ EQFALS + CMPF FA,FB ;COMPARE THEM + CFCC + BNE EQFALS + BR EQTRUE + +.ENDC + + +;ARG NOT NUMERIC. TRY STRING COMPARE +EQ.STR: MOV #LSTR,A + JSR PC,CONVERT + BEQ EQFALS ;EQUAL NOT DEFINED FOR SNAPS, ETC + EXCH B,C + JSR PC,CONVERT ;TRY CONVERTING 2ND ARG, TOO + BEQ EQFALS ;NOT SAME TYPE AS FIRST ARG + CMP B,C + BEQ EQTRUE + +;COMPARE TWO STRINGS. POINTERS IN B AND C. + SPUSH #INSTR1 + MOV C,GCP2 +CMPSTR: MOV B,GCP1 + MOV B,F +CMPST1: BIT E,F ;IS ARG 1 ENDED + BEQ CMPSTE ;YES + SPUSH A ;SAVE A + MOV F,B ;POINTER TO REST OF ARG1 + JSR PC,.LOAD + MOV A,F ;POINTER TO REST OF ARG1 + SPOP A ;RESTORE A + TSTB B ;IS CHAR REAL OR NULL? + BEQ CMPST2 ;NULL + JSR PC,@(SP)+ ;PUTS 1 CHAR OF ARG 2 INTO B + BEQ CSFAL1 ;ARG 2 ENDED + CMPB D,B ;COMPARE CHARS!! + BNE CSFALS +CMPST2: SWAB B + BIC #177400,B + BEQ CMPST1 ;NULL CHAR + JSR PC,@(SP)+ ;1 CHAR OF ARG 2 IN B + BEQ CSFAL1 + CMPB D,B ;COMPARE CHARS!! + BEQ CMPST1 +CSFALS: TST (SP)+ ;POP CO-ROUTINE LINKAGE +CSFAL1: CLR GCP1 + CLR GCP2 +EQFALS: SEZ + RTS PC + + ;ARG 1 HAS ENDED +CMPSTE: JSR PC,@(SP)+ + BNE CSFALS ;BUT ARG 2 HASN'T ENDED + CLR GCP1 + CLR GCP2 +EQTRUE: CLZ + RTS PC ;BOTH ENDED AT THE SAME TIME!!!! + + + +;CALL WITH B = POINTER TO STRING IN NODE SPACE +; C = POINTER TO STRING IN DATA SPACE +EQ.TXT: SPUSH #INTXT ;ADDRESS OF CO-ROUTINE + MOV #7777,E ;AN OFT USED CONSTANT + BR CMPSTR + + + +;MORE PREDICATES + +GREATR: JSR PC,CMP2IA + BGT RTTRUE +RTFALS: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN +RTNCMP: CLZ + RTS PC + +LESSP: +LESS: JSR PC,CMP2IA + BGE RTFALS +RTTRUE: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + BR RTNCMP + +GREQ: JSR PC,CMP2IA + BGE RTTRUE + BR RTFALS + +LSEQ: JSR PC,CMP2IA + BLE RTTRUE + BR RTFALS + +NUMBP: POPS B + MOV #INUM,A + JSR PC,CONVERT +.IFZ FPPF + BEQ RTFALS ;COULDN'T CONVERT IT + BR RTTRUE +.IFF + BNE RTTRUE + MOV #FNUM,A + JSR PC,CONVERT + BEQ RTFALS + BR RTTRUE +.ENDC + +EMPTYP: POPS B + BIT #7777,B + BEQ RTTRUE + BR RTFALS + +LISTP: POPS B + BIC #7777,B + CMP #SENT,B + BEQ RTTRUE + BR RTFALS + +WORDP: POPS B + BIC #7777,B + CMP #SENT,B + BEQ RTFALS + BR RTTRUE + +.IFZ FPPF + +;COMPARE TWO INTEGER ARGUMENTS +CMP2IA: JSR PC,G2IARG +;COMPARE 2 INTEGERS IN B,,C & E,,F +.ENDC +CMP2I: CMP E,B + BNE CMP2IR ;CONDITION CODES SET CORRECTLY + CMP F,C + BEQ CMP2IR + BHI CMP2IH +;E,,F < B,,C + CMP #0,(PC) + RTS PC +CMP2IH: TST (PC) +CMP2IR: RTS PC + +.IFNZ FPPF + +;GET AND COMPARE TWO (FNUM OR INUM) ARGS + +CMP2IA: SPUSH A + JSR PC,G2ARG + SPOP A + CMPF FB,FA + CFCC + RTS PC + +INTEGE: JSR PC,G1ARG ;GET A FNUM ARG + LDD FA,FB + MOV #INUM,F + JMP .FSTOR +.ENDC + + +NOT: JSR PC,TSTST ;TEST S SKIP IF TRUE + BEQ RTTRUE + BR RTFALS + +BOTH: JSR PC,TSTST + BNE EITH1 + JSR PC,SPOPT +BOTH1: BR RTFALS +EITH1: JSR PC,TSTST + BEQ BOTH1 + BR RTTRUE ;BOTH ARE "TRUE !! + +EITHER: JSR PC,TSTST + BEQ EITH1 ;IS 2ND ONE "TRUE? + JSR PC,SPOPT ;POP 2ND ARG + BR RTTRUE + .GLOBL BRAKE,BRK,CPLN,CTP,FLAGS,FUNLEV,IFLEV,NOPAR,OOP ;042 +.GLOBL $ELSE,$IF,$LPAR,$RPAR,CT ;043 +.GLOBL .BUG.,IS,NTF ;044 +TEST: JSR PC,TSTST ;IS TOP OF S "TRUE"? + BEQ TES1 ;NO, CLEAR FLAG + BIS #TSTFLG,FLAGS ;YES, SET FLAG + BR IFR +TES1: BIC #TSTFLG,FLAGS + BR IFR +IFTRUE: JSR PC,IFTFST ;FLAG SET? + BNE IFR ;YES, CONTINUE + BR IFT1 ;GO ACT LIKE A FAILED IF +IFFALS: JSR PC,IFTFST + BEQ IFR ;YES, CONTINUE + BR IFT1 ;NO STOP +IFTFST: INC IFLEV + BIT #TSTFLG,FLAGS + RTS PC +UNTIL: JSR PC,TSTST + BNE IFR + MOV CPLN,TMPBLK ;STORE THE CURRENT LINE NUMBER + BIT #DORF,FLAGS ;IN A DO OR RUN FRAME? + BNE UNTIL1 ;YES, DO THE UNTIL IN THIS FRAME + TST FUNLEV ;AT TOP LEVEL? + BEQ UNTIL1 ;YES, DO IT IN THIS FRAME + JMP GOUNTL + +UNTIL1: BRAKET ;CHECK FOR INFINITE LOOP IN EVLINE + MOV #HEADER,CTP ;POINT AT LINE IN CURLIN + JSR PC,IGNT ;RESET POINTERS TO THE START OF THE LINE + SEZ ;NO OUTPUT + RTS PC + +IF: INC IFLEV + JSR PC,TSTST ;TEST S, SKIP IF "TRUE" + BNE IFR +IFT1: CLR NOPAR + JSR PC,STNE + BEQ IFR + BIC #RTF,FLAGS + DEC IFLEV +IFR: SEZ + RTS PC +THEN: TST IFLEV + BGT IFR + ERROR+OOP ;THEN OUT OF PLACE +ELSE: DEC IFLEV + BGE ELSE9 +ELSE1: ERROR+OOP ;ELSE OUT OF PLACE +ELSE9: CLR NOPAR + JSR PC,STNE + BEQ IFR + TST IFLEV + BLE ELSE1 + BR IFR + STNE: ;SCAN TOO NEXT ELSE, CR OR UNMATCHED ); + ; SET RTF. SKIP IIF "ELSE" + JSR PC,GNT + CMP #$RPAR,B + BNE STNE4 + DEC NOPAR + BGE STNE + BIS #RTF,FLAGS + SEZ + RTS PC +STNE4: CMP #$LPAR,B + BNE STNE5 + INC NOPAR + BR STNE +STNE5: TST NOPAR + BGT STNE + .IFNZ ENG + CMP #$ELSE,B + BEQ STNE6 + .ENDC + .IFNZ FR + CMP #$SINON,B + BEQ STNE6 + .ENDC +STNE1: BIT #CRF,FLAGS + BEQ STNE2 +STNE3: BIS #RTF,FLAGS ;IF "CR" SET RTF AND RETURN + BIC #CRF,FLAGS + SEZ + RTS PC +STNE6: BIS #RTF,FLAGS ;IF "ELSE", SET RTF AND SKIP RETURN + RTS PC +STNE2: + .IFNZ ENG + CMP #$IF,CT ;IS "IF", LOOK FOR THE NEXT ELSE! + BEQ STNE7 + .ENDC + .IFNZ FR + CMP #$SI,CT + BEQ STNE7 + .ENDC + BR STNE +STNE7: JSR PC,STNE + BEQ STNE3 + BIC #RTF,FLAGS + BR STNE + +.GLOBL SPSWPI +TSTST: + MOV @S,B ;TEST S, SKIP IF TRUE + .IFNZ ENG + CMP B,#FALSE + BEQ TSTF9 ;IT'S "FALSE +.ENDC +.IFNZ FR + CMP B,#FAUX + BEQ TSTF9 +.ENDC +.IFNZ ENG + MOV #TRUE,C ;ERROR IF NEITHER "TRUE" OR "FALSE" + JSR PC,EQUAL1 + BNE TESTIT +.ENDC +.IFNZ FR + MOV @S,B + MOV #VRAI,C + JSR PC,EQUAL1 + BNE TESTIT +.ENDC +.IFNZ ENG + MOV @S,B + MOV #FALSE,C + JSR PC,EQUAL1 + BNE TSTF9 +.ENDC +.IFNZ FR + MOV @S,B + MOV #FAUX,C + JSR PC,EQUAL1 + BNE TSTF9 +.ENDC + ERROR+NTF ;NOT "FALSE, EITHER +TSTF9: JSR PC,SPOPT + SEZ + RTS PC ;"FALSE!! +TESTIT: JSR PC,SPOPT + CLZ + RTS PC ;"TRUE!! +REVS: CMP #1,2(P) ;REVERSES THE TOP ((P)+2) THINGS ON S + BLT 1$ ;IF <2 QUIT + RTS PC +1$: CMP #MAXARG,2(P) + BGE 2$ + .BUG. ;BARF, WHO ASKED REVS TO SWITCH > 32 THINGS? +2$: PUSH A + SPUSH B + SPUSH C + SPUSH D + MOV 10.(P),C ;GET # TO BE SWITCHED +5$: MOV S,A ;COMPUTE ADDR OF WORD JUST BEYOND BLOCK + MOV C,B + ASL B + ADD A,B + CMP IS,B ;SHOULD WE FORCE A SWAPIN? + BLO 4$ ;YES + ASR C + BEQ 9$ +8$: MOV (A),D + MOV -(B),(A)+ + MOV D,(B) + DEC C + BGT 8$ +9$: JMP RETD +4$: JSR PC,SPSWPI ;SWAP S PDL BACK IN + BR 5$ + .SBTTL DOUBLE PRECISION INTEGER ARITHMETIC +.IFZ FPPF + +;INTEGER MULTIPLICATION + +;CALL WITH ONE DOUBLE PRECISION ARGUMENT IN B,,C +;AND THE OTHER IN E,,F +;RETURNS PRODUCT IN E,,F. +;ALL OTHER ACCUMULATORS (INCLUDING B,C ARE UNCHANGED) + +.DPMUL: SPUSH A ;SAVE A + CLR A +DVML: PUSH B + SPUSH C + SPUSH D + SPUSH E + SPUSH F + PUSH B ;STUFF ABS(B,,C) + SPUSH C + SPUSH E ;AND ABS(E,,F) + SPUSH F + CLR -(SP) ;A FLAG FOR NEG. ARGS + TST B ;MAKE SURE ARGS ARE POSITIVE + BGE DVML1 + DPNEG B,C + DPNEG 10(P),6(P) ;ALSO ON STACK (FOR DIV) + COM (SP) +DVML1: TST E + BGE DVML2 + DPNEG E,F + DPNEG 4(P),2(P) + COM (SP) +DVML2: ADD A,PC ;CHOOSE BETWEEN MUL AND DIV + +;DOUBLE PRECISION MULTIPLY (CONT.) + +MUL1: TST B ;OVERFLOW UNLESS A1*A2=0 + BEQ MUL2 + TST E + BNE MDV2 ;OVERFLOW! + EXCH B,E ;WANT ARG1 TO HAVE ZERO HIGH ORDER PART + EXCH C,F +MUL2: CLR -(SP) ;SET B1 AND B2 + ASL C + BCC 1$ + MOV #100000,(SP) ;B2 +1$: ASL F + BCC 2$ + ADD #200,(SP) ;B1 (ALSO CLEARS CARRY) +2$: ROR C ;C2 + ROR F ;C1 +;IF B2*A1>0, THEN OVERFLOW + TST (SP) + BGE MUL3 ;B2=0 + TST E ;A1 + BNE MDV1 ;OVERFLOW + +;DOUBLE PRECISION MULTIPLY (CONT.) + +;GET A1*C2*(2**16.) +MUL3: + MOV C,A ;C2*A1 + MUL E,A + BCS MDV1 ;CARRY INTO A IS OVERFLOW + MOV B,ANSWER+2 ;SINCE A1*C2 IS HIGH ORDER OF ANSWER +;GET C1*C2 AND ADD INTO ANSWER + MOV C,A ;C1*C2 + MUL F,A + MOV B,ANSWER ;LOW ORDER PARTIAL PRODUCT + ADD A,ANSWER+2 ;ADDED TO A1*C2 + BVS MDV1 ;OVERFLOW +;GET C2*B1*(2**15.) AND ADD INTO ANSWER + TSTB (SP) + BEQ MUL35 ;B1=0 + CLR A + MOV C,B ;GET C2 + ASHC #15.,A ;SHIFT C2 LEFT 15 PLACES + ADD B,ANSWER ;DOUBLE PRECISION ADD + ADC ANSWER+2 + BVS MDV1 + ADD A,ANSWER+2 + BVS MDV1 +;NOW GET B2*C1*(2**15.) AND ADD INTO ANSWER +MUL35: TST (SP) + BGE MUL4 + CLR A + MOV F,B ;GET C1 + ASHC #15.,A ;SHIFT C1 LEFT 15 PLACES + ADD B,ANSWER ;DOUBLE PRECISION ADD + ADC ANSWER+2 + BVS MDV1 + ADD A,ANSWER+2 + BVS MDV1 +;NOW GET B1*B2*(2**30.) +MUL4: CMP (SP)+,#100200 ;ARE BOTH B1 AND B2 SET + BNE MUL5 ;NO (PRODUCT IS ZERO, OBVIOUSLY) + ADD #40000,ANSWER+2 ;1*2**30. + ANSWER + BVS MDV2 ;OVERFLOW +;PUT ANSWER IN THE RIGHT PLACE +MUL5: MOV ANSWER+2,E ;HIGH ORDER PARTS + MOV ANSWER,F ;LOW ORDER PARTS + TST (SP)+ ;NEGATIVE? + BEQ MUL6 + DPNEG E,F +MUL6: ADD #14,SP ;THROW AWAY E,,F, ABS(B,,C) AND ABS(E,,F) + JMP SRETD ;BUT RESTORE THE REST + +;OVERFLOW EXITS +MDV1: TST (SP)+ ;POP 2 WORDS + ABS'S +MDV2: ADD #12,SP ;POP 1 WORD + ABS'S + JMP RETF ;RESTORE ALL AC'S AND RTS + + +;DOUBLE PRECISION DIVIDE +; DIVIDE E,F BY B,C +;RETURN QUOTIENT IN E,F AND REMAINDER IN B,C +.DPDIV: SPUSH A + MOV #,A ;ADD TO THE PC IN A WHILE + JMP DVML ;INITIALIZATION. + +DIV1: TST B ;IS DEN = 0, 1, OR DOUBLE PRECISION ? + BNE DIV2 ;DOUBLE PRECISION + TST C + BLT DIV2 ;DOUBLE PRECISION (SINCE TOP BIT WAS SET) +;DEN IS SINGLE PRECISION + BEQ MDV2 ;DEN=0. OVERFLOW! + CMP C,#1 ;IS IT 1? + BNE SPDEN1 ;NO + CLR B + CLR C + BR DIV10 +SPDEN1: JSR PC,.SPDEN ;DO THE DIVISION + BR DIV10 + +;DEN IS DOUBLE PRECISION +DIV2: JSR PC,CMP2I ;IS NUM < DEN + BGE DIV5 ;NO +;NUM=DEN. +DIV5: PUSH B ;SAVE DENOMINATOR + SPUSH C + MOV B,A ;MOVE B,,C TO A,,B AND NORMALIZE + MOV C,B + CLR SHFCNT +DIV5A: INC SHFCNT ;COUNT A LEFT SHIFT + ASHC #1,A + BVC DIV5A ;UNTIL SIGN BIT CHANGES (OVERFLOW) + + ASHC #-1,A ;UNDO LAST SHIFT + BIC #100000,A ;AND CLEAR SIGN BIT WHICH WAS SET + DEC SHFCNT ;UNCOUNT THE LAST SHIFT + MOV A,C ;DIVIDE BY HIGH-ORDER OF NORMED DIVISOR + JSR PC,.SPDEN ;E,,F _ (E,,F)/(DIVISOR*2^[N-16.]) + MOV E,A ;MOV (QUOTIENT*2^[16.-N]) TO A,,B + MOV F,B + ADD #-16.,SHFCNT ;TIMES 2^[N-16.] IS TRIAL QUOTIENT + ASHC SHFCNT,A +;GET TRIAL NUM_(TRIAL QUOTIENT-1)*DEN. COMPARE WITH TRUE NUM + POP F ;E,,F _ SAVED DENOMINATOR + SPOP E + MOV B,C ;B,,C _ A,,B (TRIAL QUOTIENT) + MOV A,B + SUB #1,C ;TRY FIRST WITH Q_Q-1 + SBC B + BVS MDV2 ;OVERFLOW + JSR PC,.DPMUL + BEQ MDV2 ;MULTIPLY GOT AN ERROR (HMM!) +;COMPARE NUM TO TEM + MOV B,ANSWER+2 ;SAVE TRIAL QUO + MOV C,ANSWER +;FALLS THROUGH + ;FALLS IN +;GET TEM-NUM + MOV SP,D + TST (D)+ + SUB (D)+,F + SBC E + BVS MDV2 + SUB (D)+,E + BVS MDV2 +;TURN INTO NUM-TEM + DPNEG E,F + MOV E,B + MOV F,C + MOV (D)+,F ;E,,F_DEN + MOV (D)+,E +DIV6: TST B ;NUM-TEM + BEQ DIV7 + BGT DIV75 +;ANSWER TOO BIG. TRY ANSWER _ ANSWER - 2 + SUB #2,ANSWER + SBC ANSWER+2 + BVS MDV2 +;THIS MAKE TEM _ TEM + 2*DEN + ADD F,C + ADC B + BVS MDV2 + ADD E,B + BVS MDV2 + ADD F,C + ADC B + BVS MDV2 + ADD E,B + BVS MDV2 + BR DIV6 +DIV7: TST C + BEQ DIV9 ;TRIAL QUOTIENT = QUOTIENT !! +;TEM < NUM. EITHER QUOT=QUOT OR QUOT+1 +DIV75: JSR PC,CMP2I ;IS REM < DEN + BGT DIV9 ;YES +DIV8: ADD #1,ANSWER ;QUOT _ QUOT + 1 + ADC ANSWER+2 + BVS MDV2 + SUB F,C ;REM _ REM - DEN + SBC B + BVS MDV2 + SUB E,B + BVS MDV2 +DIV9: MOV ANSWER+2,E + MOV ANSWER,F +DIV10: TST (SP)+ ;NEG. IF ANSWER SHOULD BE NEG. + BGE DIV11 + DPNEG B,C + DPNEG E,F +DIV11: ADD #14,SP ;POP ABS(E,,F), ABS(B,,C) AND E,,F + POP D ;RESTORE D + CMP (SP)+,(SP)+ ;THROW AWAY B & C + SPOP A ;RESTORE A + CLZ + RTS PC + + + +;SINGLE PRECISION DENOMINATOR. DOUBLE PRECISION NUMERATOR. +;C=DEN. E,F=NUM. RETURNS C_REM, E,F_QUOTIENT +.SPDEN: SPUSH A + SPUSH B + ASL E ;DOUBLE E,,F + ASL F + ADC E + MOV E,B ;2E/C + CLR A + DIV C,A + MOV A,E ;2*HIGH-QUOTIENT -> E + MOV B,A ;(2REM + 2F)/2 /C + MOV F,B + ASHC #-1,A + DIV C,A + MOV A,F ;LOW-QUOTIENT -> F + MOV B,C ; REMAINDER -> C + ASR E ;HALVE E TO GET PROPER HIGH-QUOTIENT + BCC 1$ + BIS #100000,F ;& LOW BIT FROM DOUBLE-E CLOBBERS F'S SIGN BIT +1$: SPOP B + SPOP A + RTS PC +.ENDC + + +.IFNZ FPPF + + +;FLOATING DIVIDE AND MULTIPLY FROM REGS B,,C AND E,,F + +.DPMUL: PUSH A + CLR A ;SET SWITCH +.DPMU1: FPUSH FA + FPUSH FB + SPUSH C + SPUSH B + LDCIF (P)+,FA + SPUSH F + SPUSH E + LDCIF (P)+,FB ;LOAD FLOATING REGS + ADD A,PC ;WHICH ENTRY? +.DPMU5: MULF FA,FB + BR .DPMU2 +.DPMU6: LDD FB,FC ;SAVE FB + DIVF FA,FB +.DPMU2: STCFI FB,-(P) ;STACK QUOTIENT OR PRODUCT + BCS .DPERR ;TOO BIG!? + SPOP E + SPOP F ;LOAD E,,F + TST A + BNE .DPMU4 ;BRANCH ON DIVIDE +.DPMU3: FPOP FB + FPOP FA + SPOP A + CLZ + RTS PC + +.DPMU4: STCFI FB,-(P) + LDCIF (P)+,FB ;TRUNCATE QUOTIENT + MULF FA,FB + SUBF FB,FC ;GET REMAINDER + STCFI FC,-(P) + SPOP B + SPOP C ;LOAD B,,C WITH REMAINDER + BR .DPMU3 + + +.DPDIV: TST C ;DIVIDE ENTRY + BNE .DPDI1 + TST B ;DON'T DIVIDE BY ZERO + BEQ .DPERQ +.DPDI1: PUSH A + MOV #<.DPMU6-.DPMU5>,A ;SET DIVIDE SWITCH + BR .DPMU1 ;GO DO IT + +.DPERR: CMP (P)+,(P)+ ;CLEAR STACK + FPOP FB + FPOP FA + SPOP A + SEZ +.DPERQ: RTS PC + + + + +.ENDC + + +.GLOBL CNVTBL ;051 + + + + .SBTTL CONVERSION ROUTINES + + +;CONVERT +;CALL WITH DESIRED DATA TYPE IN A +;CALL WITH POINTER TO DATA IN B +;IF CONVERSION SUCCEEDS, RETURN POINTER TO CONVERTED DATA IN B AND +;LEAVE A UNCHANGED. +; +;IF CONVERSION FAILS, LEAVE B UNCHANGED,BUT RETURN ITS DATA TYPE IN A + +CONVERT: + MOV A,-(SP) ;SAVE A,B,C HERE + MOV B,-(SP) + MOV C,-(SP) + + BIC #107777,A ;LEAVE DATA TYPE ONLY + MOV B,C + BIC #107777,C + ASR A ;SHIFT DESTINATION DATA TYPE 3 PLACES + ASR A + ASR A + BIS C,A ;SET SOURCE DATA TYPE IN THE 3 VACATED BITS + ASR A ;AND PLACE THE ENTIRE MESS IN BOTTOM 6 BITS + SWAB A +;(A IS NOW A 6 BIT DISPATCH ADDRESS) + MOVB CNVTBL(A),A ;PICK UP ENTRY FROM TABLE + BIC #177400,A ;CLEAR TOP BYTE + ASL A ;IT IS A BYTE ADDRESS + JSR PC,CNVTOP(A) ;RELATIVE TO CONVERT TOP + BEQ CONV.F ;THE CONVERSION FAILED + MOV (SP)+,C + TST (SP)+ ;DON'T RESTORE B + MOV (SP)+,A + RTS PC + +CONV.F: MOV (SP)+,C + MOV (SP)+,B + MOV B,A + BIC #7777,A ;DATA TYPE OF ARG LEFT IN A + TST (SP)+ ;DON'T RESTORE A + ;FALLS THROUGH + +;CONVERT ROUTINE JUMPS TO THE PROGRAMS HERE + +DC CNVTOP,. ;TOP OF CONVERT ROUTINES + +;THE ARGUMENT CAN'T BE CONVERTED TO DESIRED DATA TYPE +.CERR: SEZ + RTS PC + + +DC CA2LS,<<.-CNVTOP>/2> +;CONVERT ATOM TO LSTR +.CATLS: JSR PC,.LOAD + +DC CNVNOP,<<.-CNVTOP>/2> +;THE ARGUMENT ALREADY HAS THE DESIRED TYPE +.CNOP: CLZ + RTS PC + + +DC CSN2IN,<<.-CNVTOP>/2> +;CONVERT SNUM TO INUM. ASSUME NUMBER IN B, RATHER THAN POINTER +.CSNIN: CLR A + TST B ;IS NUM NEGATIVE? + BGE 1$ + COM A ;SET TOP PART TO ALL 1'S +1$: JSR PC,GRBAD + BIS #INUM,C ;C POINTS TO NEW NODE + MOV C,B + RTS PC + +.GLOBL ABASE ;053 +;MORE CONVERSION ROUTINES + +DC CIN2SN,<<.-CNVTOP>/2> +;CONVERT INUM TO SNUM. RETURN NUMBER IN B +.CINSN: JSR PC,.LOAD + TST B + SXT C ;SEE IF B'S SIGN EXTENDED FILLS A. + CMP A,C + BNE .CERR + CLZ + RTS PC + + +DC CSN2LS,<<.-CNVTOP>/2> +;CONVERT SNUM TO LSTR +.CSNLS: JSR PC,.CSNIN ;CONVERT TO INUM FIRST + +DC CIN2LS,<<.-CNVTOP>/2> +;CONVERT INUM TO LSTR +.CINLS: SPUSH D + SPUSH E + SPUSH F + JSR PC,.LOAD ;A,B HAS NUMBER + JSR PC,.CINST ;CONVERT TO STRING ON P-PDL +.CINL0: CLR F + MOV #SSTR,A +.CINL1: SPOP B + BEQ .CINL2 ;0 MARKS END OF DIGITS + JSR PC,LISTB ;PUT NEXT 2 CHARS ONTO LIST + BR .CINL1 +.CINL2: POPS B ;POINTER TO FIRST NODE OF ANSWER + BIC #170000,B ;CLEAR DATA TYPE + BIS #LSTR,B ;REPLACE BY LSTR + MOV F,C ;GET PTR TO LAST NODE IN STRING + +.SRDEF: CLR GCP1 + MOV (SP)+,F + MOV (SP)+,E + MOV (SP)+,D + CLZ + RTS PC + + +;GET NEXT CHARACTER IN B +;SKIP UNLESS NO MORE CHARS +.CNXTD: TST E ;IS THERE MORE NUMBER LEFT + BNE .CNXD1 ;YES + TST F + BEQ .CNXD2 +.CNXD1: MOV #10.,C + ADD ABASE,C ;ADD DELTA ARITHMETIC BASE TO C + CLR B + JSR PC,.DPDIV ;C_REM, E,,F_QUO + BEQ .CNXD2 + ADD #60,C ;TURN TO ASCII +.CNXD2: RTS PC + +.GLOBL TEM1 ;054 + +;CONVERT INUM TO STRING ON P-PDL +.CINST: MOV (SP),TEM1 ;RETURN ADDRESS + CLR (SP) + MOV #10,D + MOV A,E + BGE .CINI1 ;NUMBER IS POSITIVE + DPNEG E,B ;NUMBER IS NEG + CLR D ;FLAG +.CINI1: MOV B,F + +.CINI2: JSR PC,.CNXTD ;GET NEXT DIGIT IN C + BEQ .CINI5 ;NO MORE CHARS + SWAB C + PUSH C + JSR PC,.CNXTD + BEQ .CINI6 + BISB C,(SP) ;SET NEW CHAR INTO PREVIOUS ONE + BR .CINI2 + +.CINI5: ADD D,PC ;NEGATIVE? + SPUSH #<55*256.> ;PUSH A MINUS SIGN IN HIGH BYTE +.CINIR: JMP @TEM1 ;RETURN + BR .CINI7 + +.CINI6: ADD D,PC ;NEGATIVE? + BIS #55,(SP) ;PUT A MINUS SIGN IN LOW BYTE + JMP @TEM1 +.CINI7: TST (SP) ;WERE ANY CHARACTERS GENERATED? + BNE .CINIR ;YES, SO RETURN + SPUSH #<60*256.> ;NO, SO PUSH A "0 IN HIGH BYTE + BR .CINIR + +;MORE CONVERSION ROUTINES + + +DC CLS2SN,<<.-CNVTOP>/2> +;CONVERT LSTR TO SNUM +.CLSSN: JSR PC,.CLSIN ;CONVERT TO INUM FIRST + BEQ .CLNR + JSR PC,.CINSN ;THEN CONVERT TO SNUM +.CLNR: RTS PC ;FAILED + +DC CLS2IN,<<.-CNVTOP>/2> +;CONVERT LSTR TO INUM +.CLSIN: BIT #7777,B ;IS B EMPTY + BEQ .CLNR ;CAN'T CONVERT EMPTY + PUSH D + SPUSH E + SPUSH F + MOV B,GCP1 ;POINT TO INPUT. (GETS CLEARED AT .RDEF & .SRDEF) + MOV B,C + CLR E + CLR F + +.CLSS0: CLR -(SP) ;A FLAG + JSR PC,INSTR1 ;GET FIRST CHAR IN D + BEQ .CLSS8 ;NO CHARS (HMM) + CMPB D,#53 ;PLUS + BEQ .CLSSA + CMPB D,#55 ;MINUS + BNE .CLSS3 ;NOT + OR - + COM 2(SP) ;-1 +.CLSSA: JSR PC,@(SP)+ + BEQ .CLSS8 + BR .CLSS4 +.CLSS1: JSR PC,@(SP)+ ;GET NEXT CHAR INTO D +.CLSS4: BEQ .CLSS9 ;ALL CHARS GOTTEN +.CLSS3: SPUSH C ;SAVE C + SUB #60,D ;CONVERT FROM ASCII + BLT .CLSS7 ;NOT DIGIT + CMPB D,#10. + BGE .CLSS7 ;NOT DIGIT + MOV #10.,C + ADD ABASE,C ;ADD DELTA ARITHMETIC BASE TO C + CLR B + JSR PC,.DPMUL + BEQ .CLSS7 ;TOO BIG + ADD D,F ;ADD NEXT DIGIT IN + ADC E + BVS .CLSS7 ;OVERFLOW + SPOP C + BR .CLSS1 + +;EITHER A NON-DIGIT CHARACTER WAS FOUND, OR ELSE +;THERE WAS OVERFLOW +.CLSS7: CMP (SP)+,(SP)+ ;POP OFF C & CO-ROUTINE LINKAGE +.CLSS8: TST (SP)+ ;POP OFF FLAG + JMP .RDEF + +;ALL CHARS GOTTEN. NUMBER IS IN E,,F +.CLSS9: TST (SP)+ ;BUT SHOULD IT BE NEG? + BGE .CLSSR ;NO + DPNEG E,F +.CLSSR: MOV E,A + MOV F,B + JSR PC,GRBAD + BIS #INUM,C + MOV C,B + JMP .SRDEF + .IFNZ FPPF + +;FLOATING POINT CONVERSION ROUTINES + +DC CSN2FN,<<.-CNVTOP>/2> +.CSNFN: SPUSH #.CINFN + JMP .CSNIN + + +DC CIN2FN,<<.-CNVTOP>/2> +.CINFN: MOV #INUM,A + JSR PC,.FLOAD + STCFD FA,-(P) +RFSTR: SPOP A + SPOP B + JSR PC,GRBAD + BIS #FNUM,C + MOV C,B + CLZ + RTS PC + + +DC CFN2IN,<<.-CNVTOP>/2> +.CFNIN: MOV #FNUM,A + JSR PC,.FLOAD + ADDF #40000,FA + CFCC + BVS .LERR1 + BGE 1$ + SUBF #40200,FA +1$: STCFI FA,-(P) + BCS .LERR + SPOP A + SPOP B + JSR PC,GRBAD + MOV C,B + BIS #INUM,B + CLZ + RTS PC +.LERR: CMP (P)+,(P)+ +.LERR1: SEZ + RTS PC + + +DC CFN2SN,<<.-CNVTOP>/2> +.CFNSN: JSR PC,.CFNIN + BEQ .LERR1 + JMP .CINSN + + +DC CFN2LS,<<.-CNVTOP>/2> +.CFNLS: SPUSH D + SPUSH E + SPUSH F + MOV #FNUM,A + JSR PC,.FLOAD + JSR PC,.CFNST + JMP .CINL0 + + + +.GLOBL FNPDL,SEXP ;057 + +DC CLS2FN,<<.-CNVTOP>/2> +.CLSFN: CLR FNPDL+2 + CLR SEXP + CLR FNPDL + STF FA,FE ;STORE FLOATING REGISTERS + STF FB,FF + CLRF FB + BIT #7777,B ;CAN'T CONVERT EMPTY LSTR + BEQ .FNLR + PUSH D + SPUSH E + SPUSH F + MOV B,GCP1 + MOV B,C + CLR E + CLR F + CLR -(P) ;A FLAG FOR THE SIGN OF NUMBER + JSR PC,INSTR1 ;GET FIRST CHAR + BEQ .FERR ;NO CHARS + SETI ;TO PREPARE FOR MOVES FROM REGS TO FLOAT REGS + CMPB D,#53 ;IS CHAR A "+? + BEQ CLSSA + CMPB D,#55 ;IS CHAR A "-? + BNE CLSS3 + COM 2(P) ;SET NEGATIVE NUMBER FLAG +CLSSA: JSR PC,@(P)+ ;GET NEXT CHAR + BEQ .FERR ;NO MORE CHAR???? + BR CLSS69 +CLSS1: JSR PC,@(P)+ ;GET NEXT CHAR +CLSS69: BEQ CLSS9 +CLSS3: SUB #60,D ;CONVERT FROM ASCII + BLT CLSS7 ;IT WASN'T A DIGIT + CMPB D,#12 + BGE CLSS7 ;IT WASN'T A DIGIT + CLR B + LDCFD #41040,FA ;CONSTANT 10 + MULF FA,FB + CFCC + BVS CLSS8 + LDCIF D,FD + INC FNPDL+2 ;SET SWITCH + ADDF FD,FB + CFCC + BVS CLSS8 ;OVERFLOWED A FLOATING REGISTER??????!!! + ADD E,F + BR CLSS1 ;GET ANOTHER CHAR +CLSS8: TST (P)+ ;DESTROY CO-ROUTINE LINKAGE + JMP .FERR +CLSS9: CLR B ;NO EXPONENT + JMP OKY +CLSS7: INC FNPDL + CMPB D,#25 ;IS IT "E? + BEQ GTEXP + CMPB D,#36 ;IS IT "N? + BEQ GTNEXP + CMPB D,#177776 ;ITS NOT ".!!?? + BNE CLSS8 + TST E + BNE CLSS8 ;THERE WERE TWO ". + DEC E + BR CLSS1 +.FNLR: LDF FE,FA ;RESTORE REGS + LDF FF,FB + SEZ + RTS PC +FERR2: POPS GCP1 + FPOP FB + FPOP FA +.FERR: TST (P)+ + LDF FF,FB + LDF FE,FA + SETL + JMP .RDEF + GTNEXP: DEC SEXP ;SET NEG EXPONENT FLAG +GTEXP: SETL + SPOP D ;SAVE CO-ROUTINE LINKAGE + FPUSH FA + FPUSH FB + JSR PC,KL ;GET EXPONENT + BEQ FERR2 + POPS GCP1 + FPOP FB + FPOP FA + SPUSH A + CLR A + JSR PC,.LOAD ;GET EXPONENT IN A,,B + TST A + BEQ OKAY + SPOP A ;THE EXPONENT WAS TOO TOO LARGE!!! + BR .FERR +OKAY: SPOP A +OKY: TST FNPDL+2 + BEQ .FERR + SETL + TST (P)+ ;THE NUMBER IS NEGATIVE? + BGE OKY1 + NEGF FB +OKY1: LDCDF #40200,D ;CONSTANT 1 + TST SEXP ;GET FINAL EXPONENT + BGE 1$ ;IS EXP NEGATIVE + NEG B +1$: CLR SEXP + ADD B,F + TST F ;GET ABSOLUTE VALUE IN F + BGE LOOP + DEC SEXP + NEG F +LOOP: DEC F ;GET 10 TO THE EXPONENT IN FD + BLT DONEX + MULF FA,FD + CFCC + BVS .FERR+2 ;TO BIG + BR LOOP +DONEX: TST SEXP ;IF EXP IS POSITIVE MULTIPLY BY IT + BLT DIVE ;IF NEG DIVIDE BY IT + MULF FD,FB ;AND PUT RESULT IN FB + CFCC + BVS .FERR+2 + BR FIN +DIVE: DIVF FD,FB +FIN: STCFD FB,-(P) + SPOP A ;GET RESULT IN A,,B + SPOP B + JSR PC,GRBAD ;STORE RESULT IN NODE SPACE + BIS #FNUM,C ;PUT POINTER TO DATA IN B + MOV C,B +; TST FNPDL +; BEQ .FERR+2 + LDF FF,FB ;RESTORE FLOATING REGS + LDF FE,FA + JMP .SRDEF +KL: SPUSH D ;SHORT FOR KLUDGE. + SPUSH E ;PREPARE TO FAKE OUT .CLSSA + SPUSH F ;IT WILL GET US AN EXPONENT + CLR -(P) ;FAKE A FLAG + SPUSH D ;RESTORE CO-ROUTINE LINKAGE + CLR E + CLR F + PUSHS GCP1 + JMP .CLSSA ;GET POINTER TO EXPONENT + + + +;CONVERT FROM FNUM TO SSTR ON P-PDL + +.CFNST: SPOP SEXP ;SAVE PC + CLR -(P) + MOV #FNPDL+16,D ;INITIALIZE STACK POINTER + TSTF FA + CFCC + BEQ .CFNZE ;ITS ZERO + BGE .CFNS0 + MOVB #'-,-(D) ;PUT IN A MINUS SIGN + NEGF FA ;PROCESS SIGN OF FNUM +.CFNS0: CLR A + LDCFD #40200,FB ;CONSTANT 1 + LDCFD #41040,FD ;CONSTANT 10 + CMPF FA,FB + CFCC + BLT .CFNS2 +.CFNS1: DIVF FD,FA ;NORMALIZE FA + INC A ;DIVIDE UNTIL 0= PRECD NEXT OPER + BLO EVI1 ;YES, > - GIVE OUTPUT TO CO + BEQ EVI4 ;YES, = - CHECK FOR _ + ;NO - NEXT TOKEN SHOULD GOBBLE THIS OUTPUT +EVI2: +.IIF NZ DEBUGR, JSR PC,STRACE + +EVI3: PUSH CO + SPUSH NOR ;NO. OF OPERANDS STILL NEEDED + MOV CT,CO + MOV CO,A ;GET FLAGS + BIC #170000,A ;CLEAR OUT THE INFIX TYPE + ASL A + MOV SOBLST(A),COF ;SET CURRENT OPERATOR FLAG + MOV #1,NOR + JMP EVW ;CALLS EVAL +EVI4: CMP #INFIX+$BKAR,CT ;PRECD ARE = - IF _ DO RIGHT ONE FIRST + BEQ EVI2 ;IT IS _ + BR EVI1 + +.GLOBL $DO,$LLPAR,EDTIF2,HNM,PREPRI,UELX ;067 +EVFUN: BIT #CRF,FLAGS ;CT IS A FUNCTION + BEQ 1$ + ERROR+UELX ;UNEXPECTED END OF LINE +1$: CMP #$LPAR,CT ;IS NEXT TOKEN A LEFT PAREN? + BNE EVF1 + TST CO ;NEXT OPERATOR? + BEQ EVF11 ;NOTHING THERE +.IFNZ ENG + CMP #$DO,CO ;IS NEXT OPERATOR A RUN COMMAND? + BEQ EVF11 +.ENDC +.IFNZ FR + CMP #$EXECUT,CO + BEQ EVF11 +.ENDC + CMP #$LLPAR,CO + BNE EVF1 +EVF11: MOV #$LLPAR,CT ;INSERT PARENS.FOR PARSE +EVF1: PUSH CO + SPUSH NOR ;NO. OF ARGS NEEDED FOR CO'S EXECUTION + CMP #$LLPAR,CO ;IF CO IS !(, PUSH IFLEV INSTEAD OF NOR + BNE EVF13 + MOV IFLEV,(P) + CLR IFLEV +EVF13: MOV CT,CO + CLR EDTIF2 +EVF2: CMP A,#UFUN ;IS POPPED OPER. A USER FUNCTION? + BLO MFUN ;NO, MACHINE + MOV #,COF ;SET PRECD TO PREPRI + JSR PC,GNASN ;GET NO. OF ARGS IN B + BNE 1$ ;FOUND A FUNCTION BINDING + ERROR+HNM ;... HAS NO MEANING +1$: MOVB B,B ;CLEAR ANY LEFT HALF FLAGS + MOV B,NOR + BEQ EVXP ;NO ARGUMENTS, THEN JUST EVALUATE IT + JMP EVL1 + +EVXP: +.IIF NZ DEBUGR, JSR PC,STRACS ;NO MORE, SPACE AND CHECK FOR SYSTEM TRACE + JSR PC,PEVAL ;SET TO EVALUATE THIS USER PROCEDURE + BEQ XNORT ;PEVAL DOES SEZ IF THERE IS NO OUTPUT + JMP XORT ;DOES CLZ IF THERE IS + .GLOBL INF1,LO,VNAF ;068 +MFUN: MOV CO,A ;GET FLAGS FOR THIS MACHINE PROCEDURE + BIC #170000,A ;CLEAR THE INFIX TYPE + ASL A + MOV SOBLST(A),A + MOV A,COF + SWAB A + BIC #ARGMSK,A ;FIND NO. OF ARGS. NECESSARY + MOV A,NOR + BNE EVS ;IS NO. ARGS = 0? (BRANCH IF NO) + BIT #PTLPF,FLAGS ;PREVIOUS TOKEN LP? + BEQ EVXM ;NO, AND NO ARGS NEEDED, EXECUTE + BIT #VNAF,COF ;VARIABLE? + BNE EVL ;YES, GO MAYBE GOBBLE ARG(S) +EVXM: JMP MEVAL ;YES. EXECUTE THIS MACHINE PROCEDURE + +XNORT: BIC #EDTIF,FLAGS + TST EDTIF2 + BEQ NORT0 + BIS #EDTIF,FLAGS +NORT0: MOV #EVDNO,A ;SET RETURN TO INDICATE NO OUTPUT +NORT1: + MOV CO,LO + POP NOR + SPOP B + MOV B,CO + CMP #$LLPAR,B ;IF POPPED OPER IS !(, IFLEV_NOR, NOR_1 + BNE NORT3 + MOV NOR,IFLEV + MOV #1,NOR +NORT3: CLR COF + TST B + BEQ NORT2 ;NO MORE OPERATORS + BIT #160000,CO ;IS IT A UFUN + BNE NORT2 ;YES + BIC #170000,B ;CLEAR THE INFIX TYPE + ASL B ;NO, MUST BE A PRIMITIVE. GET OFFSET IN BYTES + MOV SOBLST(B),COF +NORT2: JMP (A) ;RETURN DEPENDS ON WHETHER OUTPUT EXISTS +EVDNO: SEZ + RTS PC +EVS: BIT COF,#INFIX ;IS CO INFIX OP + BEQ EVL ;NO + JSR PC,CKUI ;CHECK FOR VALID UNARY INFIX +,- + BNE EVW + ERROR+INF1 ;INFIX IN WRONG PLACE +PROC: MOV @S,B ;THE WORD + BIT #7777,B ;IS IT THE EMPTY WORD + BNE 1$ + ERROR+WTA +1$: JSR PC,GUOEB ;PEVAL INVOKED VIA "#" + BEQ PROC1 + MOV B,(P) ;OLD RETURN - POPPED LATER + JSR PC,.BINDF ;IS A PROC DEFINED + BEQ PROC3 ;NO + MOV #UFUN,CO ;YES + MOV (P),B +PROC2: CLR TOPS + MOV B,CO + SPOP B ;GET P BACK IN PHASE + JMP EVF2 +PROC3: JSR PC,.LOAD ;GET PNAME FOR UOBSCH +PROC1: MOV B,TOPS + MOV #SFUN,A + JSR PC,UOBSCH ;MAKE SURE CO EXISTS + BNE 1$ + ERROR+HNM ;HAS NO MEANING +1$: MOV A,CO + BR PROC2 + +.GLOBL ERP,NIP,NOU,TIP,TMAP ;069 +EVL: BIT #PTLPF,FLAGS ;WAS PREVIOUS TOKEN A LEFT PAREN + BEQ EVL1 ;NO + BIT #VNAF,COF ;DOES CO USE VARIABLE NO. OF ARGS.? + BEQ EVL1 ;NO + CLR NOR + BR EVW9 +EVL1: JSR PC,GNT +EVW1: BIS #RTF,FLAGS ;SET REPEAT TOKEN FLAG + BIC #CRF,FLAGS +EVW: JSR PC,EVAL ;EVALUATE THIS ARGUMENT + BEQ EVW2 ;NO OUTPUT FROM EVAL + DEC NOR + BEQ EVX ;WHEN NOR = 0, WE'VE ENUF INPUTS +EVW9: JSR PC,GNT + TST NOR ;IF NOR < 0 AND NEXT TOKEN IS ")" THEN THE ")" + BGT EVW1 ;TERMINATES THE ARG SCAN FOR THE CO + CMP #$RPAR,CT + BNE EVW1 ;NO + BIS #RTF,FLAGS + BIC #CRF,FLAGS + NEG NOR + CMP #MAXARG,NOR + BGE MEVAL ;EXECUTE MACHINE PROC. + ERROR+TMAP ;TOO MANY ARGS COMMAND/OPERATION +EVX: BIT #160000,CO ;IS IT A MACHINE PROCEDURE + BEQ 1$ + JMP EVXP ;NO +1$: BIT #VNAF,COF ;MACHINE PROC NOW HAS ITS "STD" NO. OF ARGS. + ;IF IT CAN TAKE A VARIABLE NO., THEN THE "STD" NO. HAS + ;BE PUSHED ON P + BEQ MEVAL ;IT DOESN'T- GO EVALUATE IT + MOV COF,A + SWAB A + BIC #ARGMSK,A + MOV A,NOR + BR MEVAL +EVW2: + CMP #$LLPAR,CO ;EVAL SHOULD OUTPUT WHEN NOT AT TOP LEVEL + BEQ EVW ;EXCEPT WHEN CO IS LLPAR + ERROR+NOU ;WHAT, NO OUTPUT??!! + +LLPAR: +LPAR: JSR PC,GNT + CMP #$RPAR,CT + BEQ LPAR1 + ERROR+TIP ;TOO MUCH INSIDE PARENS +LPAR1: CLZ + RTS PC + +RPAR: BIT #PTLPF,FLAGS + BEQ 1$ + ERROR+NIP ;NOTHING INSIDE PARENS +1$: CMP 4(P),#$LLPAR ;IS PENDING COMMAND !( + BNE RPAR1 +RPAR2: POP A + MOV (P),IFLEV + CMP (P)+,(P)+ ;POP !( OFF THE STACK + MOV A,(P) ;CRETINOUS NON-LOCAL RETURN + SEZ + RTS PC + +RPAR1: ERROR+ERP ;EXTRA RIGHT PAREN + .GLOBL $MINUS,$PLUS,$UMINS,$UPLUS ;070 +CKUI: PUSH A + MOV CO,A + BIC #170000,A ;CLEAR THE INFIX TYPE + CMP A,#$PLUS ;+ + BNE CKUI1 + MOV #$UPLUS,A +CKUI0: + MOV A,CO + ASL A + MOV SOBLST(A),COF + MOV #1,NOR + JMP SRETA + +CKUI1: CMP A,#$MINUS ;- + BNE CKUI2 + MOV #$UMINS,A + BR CKUI0 + +CKUI2: POP A + RTS PC + +MEVAL: +.IIF NZ DEBUGR, JSR PC,STRACS + MOV CO,A + BIC #170000,A ;CLEAR OUT THE INFIX TYPE + CLR NBKTS + MOV NOR,D ;ONLY NEEDED FOR MULTIPLE ARG THINGS, BUT IT WON'T HURT... + ASL A +.IIF NZ METERS, MOV #MTPRIM,METERP ;IN A PRIMITIVE + JSR PC,@2+SOBLST(A) ;JMP ADDR IS IN 2ND WORD + BNE XORT ;PROCEDUE OUTPUTS + LDFPS #40300 +.IIF NZ METERS, MOV #MTEVAL,METERP ;IN THE EVALUATOR + JMP XNORT ;NO OUTPUT +XORT: LDFPS #40300 + MOV #EVI,A +.IIF NZ METERS, MOV #MTEVAL,METERP ;IN THE EVALUATOR + JMP NORT1 + +ORTNA: MOV A,@S + BR SRET +ORTNB: MOV B,@S + BR SRET +ORTNC: MOV C,@S + BR SRET +ORTND: MOV D,@S + BR SRET +ORTNE: MOV E,@S + BR SRET +ORTNF: MOV F,@S + BR SRET +ORTNP: MOV (SP)+,@S + BR SRET + + +ORTA: PUSHS A + BR SRET +ORTB: PUSHS B + BR SRET +ORTC: PUSHS C + BR SRET +ORTD: PUSHS D + BR SRET +ORTE: PUSHS E + BR SRET +ORTF: PUSHS F + BR SRET + DC ORTP,. +ORTSP: PUSHS (SP)+ + +RETF: POP F + BR RETE1 +RETE: POP E + BR RETD1 +RETD: POP D + BR RETC1 +RETC: POP C + BR RETB1 +RETB: POP B + BR RETA1 +RETA: POP A + SEZ + RTS PC + +RETF1: SPOP F +RETE1: SPOP E +RETD1: SPOP D +RETC1: SPOP C +RETB1: SPOP B +RETA1: SPOP A +RET: SEZ + RTS PC + +SRETF: POP F + BR SRETE1 +SRETE: POP E + BR SRETD1 +SRETD: POP D + BR SRETC1 +SRETC: POP C + BR SRETB1 + +SRETA: POP A ;POP A THEN DO CLZ RETURN + BR SRET + +SRETE1: SPOP E +SRETD1: SPOP D +SRETC1: SPOP C +SRETB1: SPOP B +SRETA1: SPOP A ;POP A THEN DO CLZ RETURN + +SRET: CLZ + RTS PC + .SBTTL PROCEDURE EVALUATOR +.GLOBL CPP,SPUSHL,TF7 ;072 +.GLOBL $COMT,$LOCAL,$USING,$AVEC ;073 +.GLOBL CPBND,CPDLP,PROEND,PROSTK,WDW ;074 +.GLOBL PBASE,SPSWPO ;075 +PEVAL: JSR PC,CKSTG ;CHECK STORAGE + MOV CO,B ;FIRST CHECK IF THE PROC IS THERE + JSR PC,.BINDF ;GET BINDING + BNE 1$ + ERROR+HNM ;PROCEDURE HAS NO MEANING +1$: JSR PC,SAVEVL ;SAVE ALL PROCEDURE INFORMATION + MOV B,C ;SAVE POINTER TO THE ARRAY WE WILL EVAL + MOV CO,B ;GET BACK POINTER TO THE ATOM + MOV B,CPP ;SET UP POINTER TO PROCEDURE NAME + JSR PC,GNASN ;GET THE NUMBER OF ARGMENTS AND FLAGS IN B + MOV B,FLAGS + MOVB B,B + SPUSH B ;PUSH # ARGS + MOV #TRRTS,TF7 ;SET TRACE DISP + BIC #--1,FLAGS ;CLEAR ALL BUT TRACE AND STEP FLAGS +.IF NZ DEBUGR + BNE PEV3 + BIT #TRACEF,FLAGS2 ;IS TRACE SET? +.ENDC + BEQ PEV6 ;NO +PEV3: +.IIF NZ DEBUGR, BIS #TPTF,FLAGS ;IT REALLY IS TRACED + MOV #TINPUT,TF7 + MOV CO,B ;SET UP B TO POINT TO THE PROCEDURE + INC FUNLEV + JSR PC,TINDNT ;SET SPACING ACCORDING TO FUNCTION LEVEL + DEC FUNLEV +STLANC +ENGINS ;PRINT PROCEDURE NAME +ENGINS +ENDENG +FRINS +FRINS +ENDLAN + MOV (P),B ;# OF ARGS +PEV6: SPUSH C ;SAVE FOR BELOW (POINTS TO LASTLINEPTR) + ;SAVE FOR BELOW POINTS TO START OF THE ARRAY + MOV B,D ;NO. OF ARGS + ADD #HEADER,C ;POINT TO THE START OF THE ARRAY DATA + SPUSH C ;PUSH POINTER TO THE ARGUMENTS LINE + ASH #2,B ;GET THE NUMBER OF BYTES WE WILL NEED ON THE STACK + NEG B + ADD S,B ;GET THE ULTIMATE VALUE OF S + CMP SPUSHL,B ;ENOUGH ROOM ON S-PDL? + BLOS 2$ ;OK + JSR PC,SPSWPO ;SWAP OUT S-PDL +2$: MOV D,B ;# OF ARGS + ASL B ;MULTIPLY BY TWO FOR OFFSET + MOV S,D + MOV D,E + SUB B,E + MOV E,S + +;DROPS INTO NEXT PAGE + ;DROPPED IN FROM ABOVE + ASR B + BEQ 3$ +1$: MOV (D)+,(E)+ ;GET ARGS ON TOP OF STACK + SOB B,1$ +3$: MOV (P),A ;GET SAVED LLP PTR + MOV A,F ;POINTER TO THE END OF THIS LINE + ADD (A),F ;POINT TO THE START OF THE NEXT LINE + ADD #2,F ;BECAUSE THE NUMBER OF VARIABLES IS ON THIS LINE + ADD #4,A ;MAKE A POINT TO THE FIRST VARIABLE + MOV A,(P) ;AND PUT IT BACK +PEV1: CMP A,F ;ARE WE AT END? + BEQ PEV11 ;YUP, GIVE UP + MOV (A)+,B ;GET THE NEXT ARGUMENT + MOV A,(P) ;PTR. TO NEXT NODE + CMP #$COMT,B ;IS CURRENT NODE A COMMENT? + BNE 1$ + JSR PC,PEVCOM ;GO PAST COMMENT + BR PEV1 ;GET A REAL THING +1$: CMP #$LOCAL,B ;IS CURRENT NODE LOCAL? + BEQ PEVLOC ;GO GOBBLE LOCALS +STLANC +ENGINS < CMP #$USING,B ;USING?> +ENGINS < BEQ PEVLOC ;SAME> +ENDENG +FRINS < CMP #$AVEC,B ;AVEC?> +FRINS < BEQ PEVLOC ;TREAT AS WITH LOCAL> +ENDLAN + BR PEV10 + +PEVCOM: CMP A,F ;ARE WE POINTING TO THE NEXT LINE? + BEQ PEVCO1 + MOV (A)+,B ;GET THE NEXT TOKEN ON THIS LINE + CMP #$COMT,B + BNE PEVCOM +PEVCO1: RTS PC + +PEV10: JSR PC,@TF7 + JSR PC,SAVVAR ;SAVE THIS VARIABLE BINDING + MOV (P),A + CMP A,F ;ARE WE AT THE END OF THE TITLE LINE? + BEQ PEV11 + BR PEV1 ;GO DO NEXT ARG + +TINPUT: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + MOV #CINPUT,TF7 + BR PINPUT + +CINPUT: PRTXT ^\, \ +PINPUT: SAVE + MOV -2(E),B ;TOP ARGUMENT + MOV B,A + INC NBKTS + JSR PC,PRTAB ;PRINT TOKEN IN A,,B + DEC NBKTS + REST +TRRTS: RTS PC + +PEVLOC: CMP A,F + BEQ PEV11 + MOV (A)+,B + MOV A,(P) + CMP #$COMT,B ;COMMENT? + BNE 1$ + JSR PC,PEVCOM ;GO PAST IT + BR PEVLOC +1$: JSR PC,LOCVAR + INC 4(P) ;CHANGE NUMBER OF ARGS + MOV (P),A + BR PEVLOC + +PEV11: SPOP C ;USED TITLE LINE POINTER +PEV2: + SPOP C ;PTR TO LLP THAT WAS PUSHED WAY ABOVE + ;POINTER TO THE START OF THE ARRAY + MOV (C),CPBND ;SET UP POINTER TO THE BINDING NODE + INC PROSTK(C) ;INCREMENT THE REFERENCE COUNT FOR THIS PROCEDURE + MOV C,F ;COPY IT + ADD #HEADER,F ;POINT TO THE PROCEDURE START + ADD (F)+,F ;POINT TO THE FIRST LINE + SUB C,F ;MAKE IT RELATIVE TO THE START OF THE PROCEDURE ARRAY + MOV F,CTP ;F POINTS TO THE FIRST EXECUTABLE LINE OF THE PROCEDURE + CMP F,PROEND(C) ;IS IT = TO THE END OF THE PROC? + BNE 1$ ;NO + CLR CTP ;OH WELL, MAKE IT STOP AT EVAL LEVEL +1$: + CMP #TRRTS,TF7 + BEQ PEV2B +PEV2A: PRCR +PEV2B: JSR PC,SAVPPS ;SAVE PDL PTRS + BIS #1,CPDLP ;INDICATES PROC PUSH AS OPPOSED TO A LOCAL PUSH + CLR CPLN + CLR CO + CLR IFLEV + INC FUNLEV +PMLOOP: JSR PC,GETLIN + JSR PC,EVLINE + BEQ PMWDW + BR PMLOOP ;LOOP BACK +PMWDW: ERROR+WDW ;WHAT SHOULD I DOO WITH (S) + +GETLIN: MOV CTP,A ;POINTER TO END OF PREVIOUS LINE + BEQ ENDPRO ;THE END OF THIS PROCEDURE + MOV A,C + MOV @CPBND,F ;GET POINTER TO START OF ARRAY + ADD F,C ;MAKE IT AN ABSOLUTE POINTER + MOV 2(C),CPLN ;GET THE LINE NUMBER + CMP A,PROEND(F) ;ARE WE AT THE END? + BEQ ENDPRO + BHI GSTBUG + MOV CPBND,PBASE ;MAKE PBASE POINT TO THE PROCEDURE IN QUESTION + BIT #TPSF,FLAGS ;PROCEDURES STEPPED? + BEQ 2$ ;NOPE + JSR PC,LINSTP ;PRINT THE LINE, AND WAIT FOR CR. +2$: +.IF NZ DEBUGR + BIT #TRACEF,FLAGS2 ;ARE WE TRACED + BEQ GSTDON ;NO, WE ARE DONE + SPUSH A ;SAVE THE POINTER TO THE LINE + CPRTXT ^\ #\ + MOV CPP,B + JSR PC,PPNAME ;PRINT PNAME + PRTXT ^\ LINE \ + MOV CPLN,A + JSR PC,PRDN + PRCR + SPOP F ;GET BACK POINTER + JSR PC,PRLN + PRCR +.ENDC +GSTDON: RTS PC +GSTBUG: .BUG. ;PROCEDURE SCREWED +ENDPRO: TST (P)+ ;POP OFF THE RETURN ADDRESS + JMP PSTOP ;STOP THIS PROCEDURE + .GLOBL .SPACE,CSPDLP,IP,PRBAO,SPRBAO ;076 +SAVVAR: ;SAVE IN (D) VARIABLE BINDING OF UOE PT'ED TO BY B + ;GIVE IT NEW VALUE WHICH IS AT (E) + ;USES A,C. TOPS MUST BE 0 + ;BOTH D AND E ARE -()ED + MOV B,-(D) ;SAVE UOE PTR + MOV #VBIND,A ;THIS WILL CHECK SPDL THINGS-- + ;NOP IT IF IT SEEMS TO CAUSE TROUBLE. RWW + JSR PC,.BINDL ;NOW GET VARIB. BINDING + BEQ SAVV2 ;NOT THERE +SAVV1: MOV -(E),A ;GET NEW VALUE PTR + MOV B,-(D) ;SAVE OLD VALUE PO[NTER + MOV A,B + JSR PC,.LDP1 + BIC #100000,A ;MAKE SURE BINDING NODE SAYS "VBIND" + JSR PC,.STORE ;STORE NEW BINDING AWAY + RTS PC + +SAVV3: TST -(E) + CLR -(D) ;THERE IS NO OLD VALUE POINTER + RTS PC + +SAVV2: TST -2(E) + BEQ SAVV3 ;IF NEW VALUE = 0, DON'T BOTHER TO CREATE CELL + MOV #VBIND,A + CLR B + JSR PC,GRBAD1 + BR SAVV1 + +SAVPPS: POP F ;SAVE P AND S PDL PTRS + SPUSH CSPDLP + MOV IS,A ;COMPUTE RELATIVE S PDL PTR + SUB S,A ;CURRENT TOP OF S-PDL + ADD SPRBAO,A ;# OF PDL BLOCKS SWAPPED OUT + MOV A,CSPDLP + SPUSH CPDLP + MOV IP,A ;COMPUTE RELATIVE P PDL PTR + SUB P,A + ADD PRBAO,A + MOV A,CPDLP + JMP (F) + +TINDNT: PUSH A ;TRACE INDENT + MOV FUNLEV,A +TIND2: DEC A + BGT TIND1 + JMP RETA +TIND1: SPACE + BR TIND2 + LOCAL: JSR PC,GUOEB ;GET UOE PTR FROM S +LOC9: MOV IS,F ;MOVE STUFF FROM S TO P PDLS + SUB S,F + ADD SPRBAO,F + MOV CSPDLP,D + BIC #1,D + SUB D,F + ASR F + MOV F,A + BLE LOC2 +LOC1: POPS D + PUSH D + DEC A + BGT LOC1 +LOC2: JSR PC,LOCVAR ;STORE AWAY POINTER AND OLD VALUE + MOV F,A ;NOW RETURN STUFF FROM P TO S + BLE LOC4 +LOC3: POP D + PUSHS D + DEC A + BGT LOC3 +LOC4: MOV IP,A ;NOW MOVE STUFF FROM P TO S + SUB P,A + ADD PRBAO,A + MOV CPDLP,D + BIC #1,D + SUB D,A + ASR A + MOV A,F + BLE LOC6 +LOC5: POP D + PUSHS D + DEC A + BGT LOC5 +LOC6: PUSH #1 ;PUSH GOODIES ON P + SPUSH CSPDLP + SPUSH CPDLP + BIC #1,CPDLP ;INDICATE LOCAL PUSH + BIC #1,CSPDLP + ADD #4,CSPDLP + ADD #6,CPDLP + MOV F,A + BLE LOC8 +LOC7: POPS D ;NOW RETURN STUFF TO P + PUSH D + DEC A + BGT LOC7 +LOC8: SEZ + RTS PC + +LOCVAR: MOV S,D ;GET THE ULTIMATE VALUE OF S + SUB #14,D ;ROOM FOR THE STUFF TO PUSH & PARANOIA + CMP SPUSHL,D ;ENOUGH ROOM ON S-PDL? + BLOS 2$ ;OK + JSR PC,SPSWPO ;SWAP OUT S-PDL +2$: MOV S,D ;NOW STORE AWAY PTR & OLD VALUE + SPUSHS #0 + MOV S,E + SPUSHS #0 + JMP SAVVAR + + +.SBTTL PROC EVAL - "OUTPUT" "STOP" +.GLOBL DOFRET,OIP,PSTOPR ;078 +.GLOBL ILINEL,PROTYP,TF3 ;079 +OIPTST: TST FUNLEV ;IN A PROCEDURE + BGT 1$ ;YES +2$: ERROR+OIP ;ONLY IN A PROCDURE +1$: BIT #BRKF,FLAGS ;ARE WE IN A BREAK LOOP + BNE 2$ + RTS PC + +OUTPUT: JSR PC,OIPTST +OUTPU2: MOV #SRET,PSTOPR ;SEZ WHEN WE RETURN + BR PSTOP1 ;AND STOP THIS PROCEDURE + +STOP: +PSTOP: JSR PC,OIPTST + MOV #RET,PSTOPR ;CLZ WHEN WE RETURN + CLR TOPS1 ;JUST RANDOM +PSTOP1: MOV #POPFRM,DOFRET ;JUST POP THE DO FRAME + BIT #DORF,FLAGS ;IS IT A DO FRAME? + BNE POPFRM ;IGNORE THE TRACE + BIT #TPTF!TPSF,FLAGS ;PROCEDURE TRACED? + BEQ POPFRM ;NO, JUST IGNORE +PSTOP3: JSR PC,TINDNT ;INDENT THE RIGHT AMOUNT + ;HERE PRINT MESSAGE + MOV CPP,B ;GET POINTER TO PROCEDURE NAME + JSR PC,PPNAME ;AND PRINT IT + CMP #SRET,PSTOPR ;OUTPUTTING? + BNE PSTOP5 ;NO, PRINT JUST "STOPS" + MOV @S,B ;GET THE OUTPUT + PRTXT ^\ OUTPUTS \ ;PRINT "OUTPUTS" + INC NBKTS ;PRINT BRACKETS AROUND THE OUTPUT + JSR PC,PNODAB ;AND PRINT THE OUTPUT + DEC NBKTS ;AND RESET FLAG + BR PSTOP8 ;PRINT CR AND CONTINUE +PSTOP5: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN +PSTOP8: PRCR ;PRINT CR. +;FALLS THROUGH, OR BRANCES INTO NEXT PAGE + +;IS BRANCHED INTO, AND FALLEN INTO FROM PREVIOUS PAGE + +;HERE IS AN ENTRY POINT FOR RESTORING THE VARIABLES FOR A FRAME +;IF OUTPUTTING, EXPECTS PSTOPR TO BE SRET, AND OUTPUT ON STACK +;POPVAR IGNORES OUPUT, AND JUST POPS THE FRAME +POPFRM: CMP #SRET,PSTOPR ;OUTPUTTING? + BNE POPVAR ;NO + POPS TOPS1 ;PUT OUTPUT INTO TOPS1 +POPVAR: JSR PC,RESPPS ;RESTORE THE PDLS + SPOP D ;GET THE NUMBER OF ARGUMENTS + BEQ PSTOP6 ;NONE, DONT BOTHER REBINDING +PSTOP4: POPS TOPS ;GET THE OLD VARIABLE BINDING + SPOPS B ;GETH THE UOE POINTER + MOV #VBIND,A ;MAKE A VARIABLE BINDING + TST TOPS ;IS IT GOING TO BE BOUND? + BEQ PVUNBN ;THEN UNBIND IT + JSR PC,.BIND ;GET A POINTER TO THE BINDING +PSTOP7: SOB D,PSTOP4 ;DO IT FOR ALL THE VARIABLES + BR PSTOP6 ;DONE WITH THIS FRAME +PVUNBN: JSR PC,.UNBND ;UNBIND IT + SOB D,PSTOP4 ;AND RETURN TO NEXT VARIABLE +PSTOP6: TST TF3 ;WAS IT A LOCAL PUSH + BEQ POPVAR ;YES, CONTINUE POPPING UNTIL WE GET TO SOMETHING + ;WITH SOME MEAT ON IT + BIT #DORF,FLAGS ;IS IT A DO FRAME? + BNE STOPDO ;STOP A DO FRAME + BIT #ERRF,FLAGS ;ERROR FRAME? + BNE 1$ ;YES, JUST RETURN + DEC FUNLEV ;ONE LESS FUNCTION LEVEL + MOV @CPBND,E ;GET POINTER TO THE ARRAY WE ARE LEAVING IN E + DEC PROSTK(E) ;DECREMENT THE REFERENCE COUNT + BLT PRCNTB ;ERROR IF LESS THAN 0 + BGT 1$ ;STILL REFENCED ON THE STACK + TST PROTYP(E) ;HAS IT BEEN DELETED? + BPL 1$ ;NO + MOV E,B ;COPY POINTER TO THE ARRAY + JSR PC,DELPRO ;AND DELETE IT +1$: JSR PC,RESEVL ;GET BACK EVAL + MOV B,FLAGS ;AND RESTORE THE FLAGS + JSR PC,POUTPU ;AND RESTACK OUTPUT IF NEEDED + JMP @PSTOPR ;SAY WE HAVE STOPPED + +STOPDO: SPOPS A ;GET BACK POINTER TO THE ILINE + MOV A,ILINEL ;GC PROTECT IT + JSR PC,WRTLIN ;AND WRITE IT AWAY + JSR PC,RESEVL ;RETORE EVAL + MOV B,FLAGS ;RESTORE THEM + JSR PC,POUTPU ;OUTPUT IF WE SHOULD + JMP @DOFRET ;AND NOW WE HAVE CLEANED UP + +POUTPU: CMP #SRET,PSTOPR ;OUTPUTTING? + BNE POUTP1 ;NO + PUSHS TOPS1 ;PUSH OUTPUT ON THE STACK + CLR TOPS1 ;AND FLUSH THE GC-PROTECTION +POUTP1: RTS PC + +PRCNTB: .BUG. ;REFENCE COUNT WAS NEGATIVE + +RESPPS: SPOP E ;RESTORE P AND S PDLS + MOV CPDLP,A + CLR TF3 + CLR TF7 + BIT #1,A + BEQ 1$ + MOV PC,TF3 +1$: BIC #1,A ;ALWAYS EVEN + JSR PC,PPTA ;POP P TO (A) + POP CPDLP ;RESTORE OLD CPDLP + MOV CSPDLP,A + BIT #1,A + BEQ 2$ + MOV PC,TF7 +2$: BIC #1,A + JSR PC,PSTA ;POP S TO (A) + SPOP CSPDLP ;RESTORE OLD CSPDLP + JMP (E) + + +.GLOBL CURLIN,PROATM ;081 +.GLOBL NCF,TOPS2 ;082 +.GLOBL CLCNT,ERPROC ;083 +RUN: +DO: JSR PC,CKSTG ;MAKE SURE THERE IS ROOM + MOV @S,A ;THE LIST TO RUN + MOV A,B ;COPY IT + BIC #7777,A ;GET TYPE + CMP #LIST,A ;IS IT A LIST + BEQ DO1 ;YES + ERROR+WTAB ;NO, THIS IS A LOSER THEN +DO1: JSR PC,BLSTI ;BUILD A LIST OF THE CHARACTERS OF THIS LIST + PUSH PCHR ;SAVE THE PRINTING ROUTINE + MOV #BLST,PCHR ;WHEN YOU PRINT A CHARACTER PUT IT INTO THIS LIST + CLR NBKTS ;NO BRACKETS NOW + JSR PC,PNODAB ;PRINT OUT THIS LIST + SPOP PCHR ;RESTORE THE PRINT ROUTINE + JSR PC,BLSTF ;NOW, FINISH THIS LIST + BEQ DO4 ;WAS THE EMPTYP LIST + MOV TOPS,@S ;PUT THE LIST WE BUILT ONTO THE STACK + JSR PC,SAVEVL ;SAVE THE EVAL STATE + PUSH #0 ;NUMBER OF ARGUMENTS + JSR PC,SAVPPS ;SAVE THE PDL POINTERS, + MOV S,A ;POINT TO THE TOP OF THE STACK + MOV (A),-(A) ;COPY THE TOKEN LIST TO CREATE A CELL FOR THE OLD COMMAND + ;BUFFER + MOV ILINEL,2(A) ;STACK POINTER TO THE ILINE + MOV A,S ;FIX STACK POINTER + ;HERE, WHEN A RESPPS IS DONE, THE TOP OF THE STACK IS + ;THE OLD ILINEL + BIC #ERRF!CATCHF,FLAGS ;THIS CANNOT BE A BOTTOM ERROR OR CATCH FRAME + BIS #DORF,FLAGS ;THIS IS A DO FRAME!!!!!! + BIS #1,CPDLP ;I AM A PROCEDURE, PUSH ME.... + MOV CPP,CURLIN+PROATM ;FAKE CPP POINTER FOR RESEVL + JSR PC,MREAD1 ;TURN CHARACTER STRING INTO THE BUFFER + BEQ 1$ ;NO TOKENS + JSR PC,EVLINE ;EVALUATE THE LINE + BNE 1$ ;DIDN'T OUTPUT + MOV #SRET,PSTOPR ;OUTPUT!!!! + BR 2$ ;RETURN.... +1$: MOV #RET,PSTOPR ;JUST RETURN, NO OUTPUT +2$: MOV PSTOPR,DOFRET ;DITTOR + JMP POPFRM ;POP THE DO FRAME AND RETURN +DO4: POPS A ;POP OFF CHARACTER STRING + SEZ ;NO OUTPUT + RTS PC + + .SBTTL CATCH AND THROW UP +CATCH: TST D + BNE 1$ ;BETTER BE AT LEAST ONE +2$: ERROR+WNA +1$: MOV S,A ;GET POINTER TO S PDL + DEC D ;IS THERE ONE ARGUMENT? + BEQ 3$ ;YES, JUST PUSH NULL TAG + DEC D ;BETTER JUST BE ONE MORE ARGUMENT + BNE 2$ ;NOPE, GIVE ERROR IN USER PROGRAM.... + MOV 2(A),B ;GET THE LIST TO RUN + MOV (A)+,(A) ;PUT TAG BACK DOWN ON FRAME + MOV B,-(A) ;PUSH BACK THE LIST TO RUN + BR CATCH1 ;GO RUN THE LIST +3$: MOV (A),-(A) ;COPY LIST TO PUT ON TOP OF STACK + CLR 2(A) ;CLEAR THE TAG FIELD + MOV A,S ;PUT BACK POINTER +;HERE ON THE S PDL IS THE TAG AND THEN THE LIST TO RUN +CATCH1: BIS #CATCHF,FLAGS ;SET THE CATCH BIT IN FLAGS + JSR PC,DO ;ACT LIKE A RUN FRAME + BEQ 1$ ;DIDN'T OUTPUT, IGNORE IT + MOV S,A ;SHOVE DOWN ON THE S PDL + MOV (A)+,(A) ;SMASH OUTPUT ON TOP OF TAG + BIC #CATCHF,FLAGS ;CLEAR CATCH FLAG + MOV A,S ;PUT BACK POINTER + RTS PC +1$: ADD #2,S ;POP OFF THE TAG + BIC #CATCHF,FLAGS ;DONT CATCH ANYTHING ELSE + SEZ + RTS PC + +;THIS IS CALLED TO THROW UP THE STACK +THROW: CLR TOPS1 ;NOT RETURNING A VALUE + TST D + BEQ THRNO ;NO ARGUMENTS, MATCH NEXT THROW + CMP #2,D ;RETURNING A VALUE? + BLO THRUP ;TWO MANY ARGS + BNE THROW1 ;NOPE, JUST SKIP THIS + SPOPS TOPS1 ;POP OFF THE OUTPUT +THROW1: SPOPS C ;GET THE TAG + BIT #7777,C ;IS IT EMPTY? + BNE THROW2 ;NO, IT IS A LEGAL TAG + CLR C ;EMPTY TAG IS SAME AS NO TAG +THROW2: MOV C,TOPS2 ;PROTECT THE TAG + MOV #THRLOP,DOFRET ;ON RETURN OF POP FRAME, COME BACK TO LOOP + MOV #THRLOP,PSTOPR +;HERE TOPS1 IS THE OUTPUT OR 0 IF NO OUTPUT +;C AND TOPS2 ARE THE POINTERS TO THE TAG ON THE THROW +THRLOP: BIT #CATCHF,FLAGS ;IS THIS A CATCH FRAME? + BNE 1$ ;YES, CHECK IT OUT +2$: TST FUNLEV ;ARE WE IN A PROCEDURE? + BNE 3$ ;YES + BIT #DORF,FLAGS ;ARE WE IN A DO OR READ FRAME? + BEQ 4$ ;NO, MUST BE AT TOP LEVEL, SO ERROR OUT +3$: JMP POPFRM ;OTHER WISE POP A FRAME +4$: ERROR+NCF ;NO CATCH FOUND +;HERE THE TOP THING ON THE PDL IS THE TAG FOR THIS CATCH OR 0 +1$: MOV TOPS2,C ;GET THE TAG ON THE THROW + BEQ THRDON ;NO TAG ON THROW, MATCHES ANY CATCH + MOV @S,B ;GET THE TAG ON THE CATCH + BEQ 2$ ;A TAGGED THROW DOESN'T MATCH A UNTAGGED CATCH + JSR PC,EQUAL1 ;COMPARE THE TAGS + BEQ 2$ ;DIFFERENT TAGS, CONTINUE SEARCH +;HERE THE CURRENT FRAME IS CORRECT, JUST CHECK FOR OUTPUT +THRDON: CLR TOPS2 ;NO LONGER NEED TAG + TST TOPS1 ;OUTPUTTING? + BEQ 1$ ;NO, DONT OUTPUT + SPUSHS TOPS1 ;PUSH IS BACK ON S + CLR TOPS1 ;CLEAR THE GC PROTECT + CLZ +1$: RTS PC ;OUTPUT + +THRNO: CLR C ;NO TAG FOR THIS THROW + BR THROW2 +THRUP: ERROR+WNA ;BAD ARGUMENTS TO THROW + +SAVEVL: POP F ;SAVE THE WORLD + SPUSH CPBND + SPUSH CLCNT + SPUSH CPLN + SPUSH CTP + SPUSH FLAGS + SPUSH CO + SPUSH CT + SPUSH IFLEV + SPUSH ERPROC + JMP (F) + +RESEVL: POP F + SPOP ERPROC ;PROC, RESTORE REST OF WORLD + SPOP IFLEV + SPOP CT + SPOP CO + SPOP B + SPOP CTP + SPOP CPLN + SPOP CLCNT + SPOP CPBND + SAVE A + MOV @CPBND,A + MOV PROATM(A),CPP + REST A + JMP (F) + .SBTTL "TO" ETC. +.GLOBL EDITA,ELW,ETYO,LDE,PARRYS,TOPRNM ;084 +.GLOBL $LINE,$TITLE,CTIT,NEC,PARRYF,PBEX,PNH,PRMTCH,TEMP ;085 +.GLOBL PAE,REDFLG,UBL ;086 +GTLN: JSR PC,GTUOEB ;GET LINE # FROM NEXT TOKEN INTO B + BEQ GTLN2 ;CANT FIND IT + MOV #SNUM,A + JSR PC,CONVER ;MAKE NEXT TOKEN INTO AN SNUM +GTLN2: RTS PC + +GTLP: PUSH CPBND ;SAVE POINTER TO EXECUTING PROCEDURE + MOV PARRYS,CPBND ;GET POINTER TO EDITING PROCEDURE + JSR PC,GTLINE ;GET POINTER TO LINE IN B + BEQ GTLP2 ;LOSES + POP CPBND ;GET BACK CPBND + MOV B,F ;RETURN POINTER + MOV PARRYS,PBASE ;SET UP BASE POINTER + SUB @PBASE,F ;FIX THIS POINTER + RTS PC +GTLP2: SPOP CPBND ;ERROR OUT + ERROR+LDE ;LINE NOT HERE + +EDTITL: TST TOPRNM + BNE 1$ + ERROR+OIP ;ONLY IN PROCEDURE +1$: JSR PC,EDITA ;SET UP FOR EDIT BUFFER INSERT + PUSH PCHR + MOV #ETYO,PCHR + MOV TOPRNM,B + JSR PC,SHTITL ;"PRINT" TITLE LINE INTO EDIT BUFFER + BNE 2$ + .BUG. +2$: MOV PC,EDTIF2 + BR EDLIN1 +EDLINE: TST TOPRNM + BNE 1$ + ERROR+OIP +1$: JSR PC,GTLN ;GET LINE # IN B + BNE 2$ + ERROR+ELW ;EDIT LINE WHAT +2$: JSR PC,GTLP ;GET PTR TO THAT LINE + JSR PC,EDITA + PUSH PCHR + MOV #ETYO,PCHR + JSR PC,PRLN ;"PRINT" THE LINE TO THE EDIT BUFFER +EDLIN1: POP PCHR + SEZ + RTS PC + +.GLOBL SIZE +;HERE WE LOOK FOR THE TOKEN $LINE OR $TITLE, IF NOT THAT WE ERROR OUT, +EDITSY: +.IFNZ ENG + CMP #$TITLE,B ;IS IT EDIT TITLE? + BEQ EDTITL ;YES + CMP #$LINE,B ;IS IT EDIT LINE? + BEQ EDLINE ;YES +.ENDC +.IFNZ FR + CMP #$TITRE,B ;AS ABOVE BUT IN FRENCH + BEQ EDTITL + CMP #$LIGNE,B + BEQ EDLINE +.ENDC + ERROR+NEC ;CAN'T BE EDITED + +EDIT: BIC #EDTIF,FLAGS ;SO THAT WE ARE NO LONGER EDITING TITLES + JSR PC,GTUOEB ;GET POINTER TO THE USER OBLIST ELEMENT + BNE EDITSY ;WASN'T A UOE + TST TOPRNM ;EDITING ANYTHING CURRENTLY? + BEQ EDIT2 ;NO +EDIT1: ERROR+CTIT ;CANT TO IN TO +EDIT2: MOV B,TEMP ;STORE THE POINTER TO THE ATOM + CLR TOPS ;MAKE SURE WE DONT CREATE A NEW BINDING + JSR PC,.BINDF ;SEE IF IT HAS A PROCEDURE BINDING + BNE EDIT4 ;IT DOES + ERROR+PNH ;PROCEDURE NOT HERE +EDIT4: TST PROSTK(B) ;IS THE PROCEDURE EXECUTING BACK UP THE STACK? + BEQ 1$ ;NO + ERROR+PBEX ;PROCEDURE BEING EXECUTED (HUNG) +1$: MOV (B),PARRYS ;SET UP FOR THE EDIT, + ;POINTER TO BINDING NODE FOR THIS ARRAY + MOV SIZE(B),PARRYF ;POINT TO THE END OF THE ARRAY + SUB PROEND(B),PARRYF ;SUBTRACT POINTER TO THE END OF USED STORAGE AND DONE +EDIT5: MOV TEMP,TOPRNM ;STORE THE PROCEDURE NAME AWAY + MOV #'>,PRMTCH ;CHANGE PROMPTING CHARACTER TO > + CLR TOPS2 +CLRTP1: CLR TOPS1 +CLRTOP: CLR TOPS ;CLEAR ALL TEMPORARYS + RTS PC + + +TO: JSR PC,GTUOEB ;GET THE UOE POINTER + BEQ 1$ ;FINE + CMP #INFIX,A ;IS IT A SYSTEM FUNCTION + BHIS 2$ ;YES + ERROR+WTAB ;CANT EDIT LISTS AND SUCH +2$: ERROR+UBL ;USED BY LOGO +1$: BIC #170000,B ;GET ONLY THE POINTER PART + BIS #UFUN,B ;MAKE SURE IT IS A UFUN + MOV B,TOPS2 ;STORE IT AWAY + MOV B,TEMP ;FOR ERROR MESSAGE + CLR TOPS ;SO THAT WE DONT CAUSE A BINDING YET. + JSR PC,.BINDF ;GET THE PROCEDURE BINDING FOR PROC IN B + BEQ TO2 ;DOESN'T EXIST + BIT #EDTIF,FLAGS ;ARE WE EDITING THE TITLE? + BEQ 3$ ;NO, CHECK TO SEE IF READ FROM FILE + CMP TEMP,TOPRNM ;ARE WE USING THE SAME NAME? + BEQ TITLED ;YES, FINE + ERROR+PAE ;BARF, THIS PROCEDURE ALREADY EXISTS +3$: TST REDFLG ;IS IT INPUT FROM THE TTY? + BEQ 4$ ;YES, FAIL IMMEDIATELY + ADD CLCNT,CTP + ADD CLCNT,CTP ;MOVE POINTER TO END OF LINE + CLR CLCNT ;SAY END OF LINE + BIS #SPDF,FLAGS ;SAY WE ARE SKIPPING THIS PROCEDURE + BR EDIT5 ;CLEAN UP +4$: ERROR+PAE ;PROC (TEMP) ALREADY EXISTS +TO2: TST TOPRNM ;ARE WE IN EDIT MODE CURRENTLY? + BNE TITLED ;YES, WELL BETTER BE EDITING THE TITLE + JSR PC,TITLDF ;SET UP PROCEDURE ARRAY... RETURN POINTER IN B + MOV #FBIND,A ;SET UP THE FUNCTION BINDING TO POINT TO THE NEWLY + ;CREATED ARRAY, C WAS SET UP BY .BINDF, AND IS USED + ;BY GRBAD1 +TOBND: MOV TEMP,PROATM(B) ;PUT THE POINTER TO THE PNAME OF THIS ATOM INTO + ;THE FIRST DIMENSION + MOV B,PARRYS ;MAKE PARRYS, POINT TO THE ARRAY START + MOV #PARRYS,(B) ;AND THE ARRAY POINT TO PARRYS (FAKE A BINDING NODE) + JSR PC,GRBAD1 ;NEW FUNCTION BINDING FOR THIS ATOM + ASL C + ASL C ;MAKE POINTER TO THE NODE + ADD #NODESP+2,C ;MAKE POINTER TO THE BINDING NODE + MOV C,@PARRYS ;CLOBBER THE ARRAY TO POINT TO THE BINDING NODE + MOV PARRYS,(C) ;CLOBBER BINDING NODE TO POINT TO THE ARRAY + ;IN LSI VERSION ARRAY MAY HAVE MOVED IN GRBAD1 + MOV C,PARRYS ;SET UP POINTER TO THE START OF THE ARRAY + MOV F,S ;RESET S POPPING OFF ARGUMENTS TO TO: HERE, THE PROCEDURE + ;IS ENTIRELY CONSISTENT AND GC MARKED + BR EDIT5 ;SET UP PROMPT AND CLEAN IT UP + +;CALLED WITH C POINTING TO THE END OF THE BINDING LIST FOR THE NEW NAME +;OLD NAME IS IN TOPRNM +;TEMP POINTS TO THE NEW NAME +TITLED: BIT #EDTIF,FLAGS ;EDITING THE TITLE? + BEQ EDIT1 ;NO, CANT TO IN TO + SPUSH C ;SAVE POINTER TO THE BINDING NODE + JSR PC,CHKTIT ;CHECK THE TITLE, D <= THE NUMBER OF ELEMENTS ON LINE + ;ARGUMENTS PUSHED ON THE S PDL + ;F GETS THE REAL NUMBER OF ARGS + MOV @PARRYS,E ;THE START OF THE OLD ARRAY + ADD #HEADER,E ;POINT TO THE START OF THE PROCEDURE STRUCTURE + MOV F,2(E) ;PUT IN NEW NUMBER OF ARGUMENTS + SPUSH D ;SAVE ARGUMENTS + ASL D ;NUMBER OF BYTES NEEDED FOR THE ARUMENTS + ADD #2,D ;BECAUSE WE NEED A WORD SAYING HOW MANY ARGS, + SPUSH D ;SAVE THE LENGTH OF THE NEW LINE + SUB (E),D ;THE LENGTH DIFFERENCE IN BYTES + JSR PC,MAKSPA ;BYTE DIFFERENCE IN D, POINTER TO PLACE IN E + ;WILL EITHER CONTRACT OR EXPAND ARRAY AS NEEDED + SPOP (E)+ ;POP THE LINE LENGTH + MOV F,(E)+ ;AND THE NUMBER OF ARGUMENTS + SPOP D ;GET THE NUMBER OF ARGUMENTS + BEQ 1$ ;NONE, FORGET IT + MOV D,A ;COPY IT + ASL A ;INTO BYTES + ADD S,A ;MAKE IT A RELATIVE POINTER TO THE S PDL + SPUSH A ;WHERE THE PDL POINTER WILL BE WHEN WE ARE DONE +2$: MOV -(A),(E)+ ;PUT IN THE ARGUMENTS + SOB D,2$ ;TAKE ALL THE ARGUMENTS OFF THE S PDL + SPOP S ;NOW RESTORE THE S-PDL +1$: CMP TEMP,TOPRNM ;ARE THE NAMES THE SAME? + BNE NEWTIT ;NO, WE MUST UNBIND THE OLD NAME, AND CREATE NEW BINDING + SPOP C ;JUST FLUSH THE NEW BINDING NODE POINTER + JMP EDIT5 ;AND CLEAN UP +NEWTIT: MOV #FBIND,A ;REMOVE THE FUNCTION BINDING + MOV TOPRNM,B ;UNBIND THE OLD ONE + SPUSH @PARRYS ;PUSH THE PROCEDURE ADDRESS + JSR PC,.UNBND ;DO THE DEED + SPOP B ;GET IT INTO B + SPOP C ;GET BACK POINTER TO WHERE THE NEW PROC BINDING GOES + MOV S,F ;PUT POINTER TO POP S TO IN F + BR TOBND ;BIND IT LIKE YOU WERE DOING A TO + +GTUOEB: JSR PC,GNT ;GET UOE PTR FROM NEXT TOKEN IN B + BIT #CRF,FLAGS + BEQ 1$ + ERROR+UEL ;UNEXPECTED END OF LINE +1$: BIC #7777,A ;SKIP UNLESS NEXT TOKEN NOT UOE. USES A + CMP #UFUN,A + BEQ GTU1 + CMP #ATOM,A + BEQ GTU1 + CMP #LSTR,A + BNE GTU2 + MOV B,TOPS + JSR PC,.INTRN +GTU1: CLR TOPS +GTU2: RTS PC + + +CONTIN: + MOV #POPVAR,DOFRET ;POP OFF DO FRAMES + MOV #CNTIN1,PSTOPR ;AND CHECK FOR ERROR FRAMES +CNTIN1: TST FUNLEV ;IN A PROCEDURE? + BEQ CNTIN3 ;NOT ANY MORE + BIT #ERRF!BRKF,FLAGS ;IS THIS THE BOTTOM LEVEL ERROR PROCEDURE? + BNE CNTIN2 ;YES + JMP POPVAR ;POP A FRAME... +CNTIN2: MOV #CNTIN4,PSTOPR ;POP OFF THE ERROR FRAME + JMP POPVAR ;POP IT +CNTIN4: MOV #CNTIN5,DOFRET ;POP OFF ALL THE DO FRAMES +CNTIN5: BIT #DORF,FLAGS ;DO FRAME? + BEQ CNTIN6 ;NOPE + JMP POPVAR ;POP IT OFF +CNTIN6: JMP PMLOOP ;RESTART A MLOOP (I.E. THE NEXT LINE + ;IF WE WANT TO ALLOW PROCEDES TO WIN TOTALLY, WE SHOULD + ;MAKE SURE ALL ERROR+BRK GET CONTINUED CORRECTLY, AND + ;HERE WE SHOULD CALL PSTOP. THAT IS ALL ERROR+BRKS MUST + ;BE FOLLOWED BY A BRANCH TO A GOOD PLACE TO CONTINUE FROM + ;JUST STOP THE ERROR FRAME, AND RETURN +CNTIN3: JMP TOPLEVEL ;JUST RETURN TO TOPLEVEL + + +RETURN: JSR PC,G1NARG ;GET THE LINE TO RETURN TO + MOV B,TMPBLK ;SAVE IT FOR A BIT + MOV #RETUR1,PSTOPR ;AND CHECK FOR ERROR FRAMES + MOV #POPVAR,DOFRET ;POP OFF DO FRAMES +RETUR1: TST FUNLEV ;IN A PROCEDURE? + BEQ CNTIN3 ;NOPE + BIT #ERRF!BRKF,FLAGS ;IS THIS THE BOTTOM LEVEL ERROR PROCEDURES + BNE RETUR2 ;YES, DO A JUMP TYPE THING +RETUR3: JMP POPVAR ;POP A FRAME +RETUR2: MOV #GOUNTL,PSTOPR ;AND POP THE ERROR PUSH, AND GET BACK TO PROCEDURE + BR RETUR3 + +GO: JSR PC,OIPTST ;MAKE SURE WE ARE IN A PROCEDURE + JSR PC,G1NARG ;GET THE LINE TO JUMP TO + MOV B,TMPBLK ;SAY IT +GOUNTL: MOV #GOUNTL,DOFRET ;COME HERE AGAIN IF IT IS A DO + BIT #DORF,FLAGS ;IS IT A DO FRAME? + BNE RETUR3 ;POP A DO FRAME + + MOV CPDLP,A ;POP THE P STACK BACK TO THE START FOR THIS FRAME + BIC #1,A ;USED AS A FLAG + JSR PC,PPTA ;POP THE P TO (A) + MOV CSPDLP,A ;AND DO THE SAME TO S + BIC #1,A + JSR PC,PSTA ;POP THE S PDL TO (A) + MOV TMPBLK,B + JSR PC,GTLINE ;GET A POINTER TO THE LINE + BNE 1$ + ERROR+LDE ;LINE B DOESN'T EXIST +1$: SUB @CPBND,B ;MAKE B RELATIVE + MOV B,CTP + MOV TMPBLK,CPLN + JMP PMLOOP ;JUST GO TO THE NEXT LINE + .GLOBL NSL,PROCAR,PRSIZE ;091 +.GLOBL WIT ;092 +.GLOBL LASTPR ;093 +TITLDF: PUSH C + JSR PC,CHKTIT ;PUSH ARGUMENTS ON THE S-PDL, AND RETURN NUMBER IN D + MOV D,B ;NUMBER OF ARGUMENTS + ASL B ;NUMBER OF BYTES + ADD #4+HEADER+PRSIZE,B ;NUMBER OF BYTES IN ARRAY OVERHEAD, AND THE SIZE INIT + JSR PC,..ALLO ;ALLOCATE AN ARRAY OF THAT SIZE + BNE 1$ ;OKAY + ERROR+NSL ;NO STORAGE LEFT +1$: MOV A,C ;COPY IT + MOV A,PARRYS ;STORE THE START OF THE ARRAY (CLOBBERED LATER TO POINT TO THE + ;BINDING NODE FOR THIS PROCDURE + MOV B,PARRYF ;NUMBER OF BYTES TO BE USED+HEADER LENGTH + CMP (C)+,(C)+ ;SKIP BACK POINTER TO ATOM, AND LENGTH + MOV #PROCAR,(C)+ ;PROCEDURE ARRAY + CLR (C)+ ;ONE DIMENSIONAL + CLR (C)+ + CLR (C)+ ;THIS WILL BE THE TOTAL LENGTH OF THE PROCEDURE EVENTUALLY + ADD #10,C ;SKIP INFO FOR WINDOWS + MOV D,B ;NUMBER OF ARGS + INC B ;ONE FOR THE NUMBER + ASL B ;GET LENGTH IN BYTES + MOV B,(C)+ + MOV F,(C)+ ;NUMBER OF ARGS + MOV S,F ;IN CASE WE BRANCH AROUND + TST D ;ANY ARGUMENTS? + BEQ TITDON ;NO, WE ARE FINISHED + MOV D,B ;NUMBER OF ARGUMENTS WE PUSHED ON S + ASL B ;INTO A BYTE NUMBER + ADD F,B ;GET NEW S POINTER + SPUSH B ;SAVE IT FOR LATER +ARGLOP: MOV -(B),(C)+ ;PUT IN POINTER TO THE ARUMENT + SOB D,ARGLOP ;FOR ALL OF THEM + SPOP F ;AND NOW SET F TO WHAT S SHOULD BE PUT BACK TO BY TOBND +TITDON: MOV PARRYS,B ;GET POINTER TO START OF THE ARRAY + SUB B,C ;GET NUMBER OF BYTES USED + MOV C,PROEND(B) ;PUT IN POINTER TO THE FIRST FREE LOCATION INTO 1 DIMENSION + SUB C,PARRYF ;AND SET UP NUMBER OF BYTES LEFT + SPOP C + RTS PC ;DONE + +CHKTIT: CLR D ;COUNTER FOR NUMBER OF TOKENS + CLR F ;COUNTER FOR NUMBER OF ARGS + SAVE #2 ;FLAG + CMP SPUSHL,S ;ENOUGH ROOM ON THE S PDL? + BLOS CHKTI0 ;YES + JSR PC,SPSWPO ;SWAP OUT SOME OF S +CHKTI0: DEC CLCNT ;ANY MORE TOKENS ON THE LINE? + BMI CHKTI1 ;DONE + MOV CTP,A ;GET POINTER + ADD @CPBND,A ;RELOCATE + MOV (A),B ;GET TOKEN + MOV B,A ;COPY IT + ADD #2,CTP ;MOVE POINTER ONWARDS + BIC #7777,A + INC D + TST (P) ;ARE WE IN A COMMENT? + BLT 1$ ;NO ARGS WITHIN COMMENT + CMP #$LOCAL,B ;IS IT LOCAL? + BEQ 2$ +STLANC +ENGINS < CMP #$USING,B ;USING?> +ENGINS < BEQ 2$ ;SAME> +ENDENG +FRINS < CMP #$AVEC,B ;AVEC?> +FRINS < BEQ 2$ ;TREAT AS WITH LOCAL> +ENDLAN + BR 3$ ;NOPE +2$: MOV #1,(P) ;CHANGE FLAG + BR CHKTI3 ;GO STORE IT AWAY +3$: CMP #UVAR,A + BEQ CHKTI3 + CMP #UFUN,A ;BBN MODE OF VARIABLE DECLARE + BEQ CHKTI3 +1$: CMP #$COMT,B ;IS IT ! ? + BNE CHKTER ;NOPE + NEG (P) ;FLIP COMMENT FLAG + +CHKTI3: BIT #100001,(P) ;IS FLAG ODD OR NEGATIVE? + BNE 1$ ;COMMENT OR LOCAL ARG + INC F ;A REGULAR ARG +1$: CMP D,#MAXARG ;TO MANY ARGS? + BGE CHKTI0 ;YES, DONT PUSH ANY MORE + PUSHS B ;PUSH ON THE TOKEN + BR CHKTI0 ;AND GO FOR THE NEXT +CHKTER: TST (P) ;ARE WE IN A COMMENT? + BLT CHKTI3 ;YUP, ANYTHING GOES + TST A ;IS THE TYPE SFUN? + BNE 1$ ;NOPE, LOSER + CMP #$DOTS,B ;SPECIAL CASE + BEQ 1$ + SAVE TEMP ;UGH + JSR PC,LSFUN ;CONVERT SFUN TO LSTR + MOV #UVAR,A ;TYPE FOR .INTRN + JSR PC,.INTRN ;FAKE UP AN ATOM + BIC #170000,B + BIS #UFUN,B ;FAKE UFUN + CLR TOPS + REST TEMP ;BLETCH + BR CHKTI3 +1$: MOV B,CT + ERROR+WIT ;WRONG TYPE OF INPUT TO "TO" +CHKTI1: CMP #MAXARG,D + BGE CHKTI2 + ERROR+TMAP ;TOO MANY ARGS (PROCEDURE) +CHKTI2: TST (P)+ ;FLUSH COMMENT FLAG + RTS PC + END: MOV TOPRNM,B + BNE 1$ + ERROR+OIP ;ONLY IN PROCEDURE DEFINITION +1$: MOV B,LASTPR ;SAVE FOR "PO" + TST REDFLG + BEQ END4 + BIT #SPDF,FLAGS + BEQ END3 +END4: BIT #SPDF,FLAGS ;DOUBLE DEFINED? + BNE END5 ;YUP, GIVE MESSAGE + TST FUNLEV ;DON'T PRINT "FOO DEFINED" IF NOT AT TOP LEVEL + BEQ END5 + BIT #BRKF,FLAGS + BEQ END3 +END5: JSR PC,PPNAME + BIT #SPDF,FLAGS + BNE END1 +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + +END3: MOV @PARRYS,B ;GET ADDRESS OF PROCEDURE JUST DEFINED + MOV SIZE(B),A ;GET TOTAL SIZE + SUB PROEND(B),A ;GET UNUSED SPACE + CMP #HEADER,A ;IS THERE ENOUGHROOM FOR A HEADER? + BHI END7 ;NOPE, LEAVE IT ALONE + SUB A,SIZE(B) ;GET RID OF EXCESS SPACE + ADD SIZE(B),B ;POINTER TO SPACE TO BE FREED + MOV A,SIZE(B) ;FAKE AN ARRAY HEADER + JSR PC,.RELES ;AND RELEASE THE SPACE +END7: CLR TOPRNM + BIC #SPDF,FLAGS + MOV #'?,PRMTCH + SEZ + RTS PC +END1: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + BR END7 + .SBTTL UTILITY - COUNT LIST ELEMENTS +CLE: ;COUNT LIST ELEMENTS + ;IN - LIST PTR IN C + ;OUT - # OF ELEMENTS IN B + PUSH A + SPUSH C + CLR B + MOV C,A +CLE1: BIT #7777,A + BEQ CLE2 + MOV A,C + JSR PC,.LDP1 + INC B + BR CLE1 +CLE2: POP C + SPOP A + RTS PC + .SBTTL UTILITY - ADD A LINE +;TAKES POINTER TO ATOM IN B, AND OUTPUTS NUMBER OF ARGUMENTS IN B +;SET Z IF PROCEDURE IS NOT FOUND +GNASN: PUSH A + SPUSH B + SPUSH C + JSR PC,.BNDFS ;GET THE BINDING INTO B + BNE 1$ ;FOUND IT + JMP RETC +1$: ADD #HEADER,B ;POINT TO THE START OF THE PROCEDURE + MOV 2(B),2(P) ;PUT THE # OF ARGS INTO B ON THE STACK + JMP SRETC + +GTLINE: ;LINE NUMBER IN B, OUTPUT POINTER TO LINE IN B + ;PROCEDURE POINTED TO BY CPADR + ;SET Z IF NOT FOUND + SPUSH A + SPUSH B + SPUSH C + SPUSH D + MOV @CPBND,C ;GET POINTER TO THE START OF THE ARRAY + MOV PROEND(C),D ;POINTER TO THE END OF THE ARRAY + ADD C,D ;MAKE IT AN ABSOLUTE POINTER + ADD #HEADER,C ;POINT TO THE START OF THE DATA +GTLIN1: ADD (C)+,C ;GET TO THE NEXT LINE + CMP C,D ;ARE WE AT THE END OF THE PROC? + BEQ GTLINF ;YES, WE HAVE FAILED TO FIND IT + BHI GTLINB ;OOPS WE SHOULDN'T OVERSHOOT + CMP B,2(C) ;ARE THE LINE NUMBERS THE SAME? + BGT GTLIN1 ;THE ONE WE ARE LOOKING FOR IS FURTHER ON + BLT GTLINF ;WE PASSED WHERE IT SHOULD BE, FAIL + MOV C,4(P) ;CLOBBER B ON THE STACK + JMP SRETD ;AND RETURN +GTLINF: JMP RETD +GTLINB: .BUG. + ;CALLED WITH THE LINE NUMBER IN B +;IF NEGATIVE DELETE THAT LINE +;IF NOT INSERT LINE POINTED TO BY CTP, CLCNT IS EXPECTED TO BE CORRECT +ADLN: JSR F,CACSAV ;CAREFULLY SAVE THE AC'S + CLR A ;A FLAG + MOV B,F ;THE LINE NUMBER + BPL FINLIN ;FIND THE LINE AND INSERT IT + NEG F ;GET THE REAL LINE NUMBER + INC A ;FLAG FOR JUST DELETING LIEN +FINLIN: MOV @PARRYS,E ;POINTER TO THE START OF THE ARRAY + MOV PROEND(E),B ;THE POINTER TO THE FIRST FREE LOCATION + ADD E,B ;MAKE IT ABSOLUTE + ADD #HEADER,E ;POINT TO THE BEGINNING OF THE PROCEDURE +LINLOP: ADD (E)+,E ;POINT TO THE NEXT LINE + CMP E,B ;ARE WE AT THE END? + BEQ ADDEND ;YES + BHI ADDBUG ;CANT BE... + CMP F,2(E) ;ARE THE LINE NUMBERS THE SAME? + BGT LINLOP ;NO, IT MUST BE FURTHER ON + BEQ LINEQ ;INSERT THE LINE (E) +ADDEND: TST A ;DELETING THE LINE? + BNE LINDN2 ;CANT FIND THE LINE TO DELETE IT + JSR PC,LINLEN ;GET THE LENGTH OF THE LINE IN BYTES INTO D+4 FOR + ;LENGTH AND LINE NUMBER + JSR PC,MAKSPA ;AND MAKE SPACE FOR IT + SUB #2,D ;SUBTRACT FOR THE LENGTH WORD + MOV D,(E)+ ;SET IN THE LINE LENGTH + MOV F,(E)+ ;THE LINE NUMBER +LINDON: JSR PC,INSLIN ;AND THE LIST +LINDN2: JSR F,CACRES + RTS PC +ADDBUG: .BUG. + +;HERE WE DELETE THE LINE (E), AND INSERT LINE POINTED TO BY A +LINEQ: TST A ;ANY LIST TO INSERT? + BNE NOLIST ;NO JUST DELETE THE LINE + JSR PC,LINLEN ;GET THE LENGTH OF THE LINE IN D + SUB #2,D ;BECAUSE WE DONT COUNT THE LENGTH WORD NOW + SPUSH D ;SAVE IT FOR LATER + SUB (E),D ;GET THE DIFFERENCE BETWEEN THE TWO LINES + JSR PC,MAKSPA ;MAKE SPACE FOR THE LINE + SPOP (E)+ ;SET IN THE LENGTH + MOV F,(E)+ ;AND LINE NUMBER + BR LINDON ;DONE WITH THE LINE +NOLIST: MOV (E),D ;GET THE NUMBER OF DELTA BYTES + ADD #2,D ;BECAUSE WE ARE DELETING THE LENGTH ALSO + NEG D ;IT IS GETTING SMALLER + JSR PC,MAKSPA ;FIX THIS LINE + BR LINDN2 ;JUST RETURN + +;RETURN NUMBER OF BYTES NEEDED FOR THE LINE IN D +LINLEN: MOV CLCNT,D ;GET NUMBER OF TOKENS LEFT + ASL D ;FROM WORDS TO BYTES + ADD #4,D ;FOR THE LINE NUMBER, AND LENGTH + RTS PC +;PUT LINE POINTED TO BY CTP INTO ARRAY POINTED TO AT E +INSLIN: TST CLCNT ;ARE THERE ANY MORE TOKENS LEFT? + BEQ INSDON ;NO + MOV @CPBND,B ;GET POINTER TO THE START OF THE LINE'S PROCEDURE + ADD CTP,B ;POINT TO THE LINE TO INSERT + MOV CLCNT,C ;NUMBER OF TOKENS TO INSERT + ADD C,CTP ;MUST FIX CTP + ADD C,CTP ;TO POINT TO END OF LINE +1$: MOV (B)+,(E)+ ;COPY THE TOKENS + SOB C,1$ +INSDON: RTS PC + + .GLOBL PROINC ;098 + +;MAKE SPACE FOR D BYTES AT (E). IF D IS NEGATIVE COLLAPSE SPACE. +;IF D IS POSITIVE, EXPAND THE ARRAY IF NEEDED, COPY THE ARRAY, LEAVING D +;BYTES AT THE ORIGINAL E +;PARRYS AND PARRYF ARE UPDATED IF NEEDED, AND 1 DIMENSION OF ARRAY ALSO +MAKSPA: TST D + BEQ SPADON ;NOTHING NEED BE DONE + BPL SPAEXP ;NEED TO EXPAND MAYBE + JSR F,CACSAV ;SAVE THE AC'S + SUB D,PARRYF ;MAKE THE FREE SPACE A LITTLE LARGER + MOV @PARRYS,A ;POINT TO THE START OF THE ARRAY + MOV PROEND(A),B ;GET POINTER TO THE FIRST UNUSED LOCATION + ADD A,B ;MAKE IT AN ABSOLUTE POINTER + ADD D,PROEND(A) ;DECREASE THE POINTER BY THE AMOUNT SHIFTED DOWN + MOV E,F ;COPY POINTER TO WHERE WE ARE MUNGING + SUB D,F ;MAKE IT POINT AHEAD D BYTES + SUB F,B ;GET NUMBER OF BYTES TO TRANSFER + BLE SPADN1 ;NUMBER OF BYTES DELETING IS MORE THAN FROM (E) TO END OF PROC. + ASR B ;GET NUMBER OF WORDS +MAKSP1: MOV (F)+,(E)+ ;TRANSFER THEM + SOB B,MAKSP1 ;FOR ALL THE BYTES +SPADN1: JSR F,CACRES ;GET BACK THE AC'S +SPADON: RTS PC ;AND RETURN +SPAEXP: JSR F,CACSAV ;SAVE THE AC'S + CMP D,PARRYF ;IS THERE ENOUGH FREE SPACE TO WIN ON THIS PROCEDURE? + BLE NUFSPA ;YES +;HERE WE HAVE TO TRY TO EXPAND THE ARRAY + MOV @PARRYS,A ;POINT TO THE BEGINNING OF THE CURRENT ARRAY + MOV SIZE(A),B ;GET THE CURRENT SIZE + SUB A,E ;MAKE POINTER TO WHERE TO INSERT RELATIVE TO OLD ARRAY START + ADD D,B ;GET NEW NUMBER OF BYTES NEEDED + ADD #PROINC,B ;AND ADD A LITTLE EXTRA FOR EFFICIENCY + JSR PC,..ALLOC ;GET A NEW ARRAY OF THAT SIZE, POINTER IN A + BEQ NOSPA ;NO SPACE + MOV @PARRYS,C ;GET ADDRESS OF OLD ARRAY + ADD C,E ;MAKE IT POINT TO THE POSSIBLE NEW PLACE +;HERE THE OLD ARRAY IS CONSISTENT AGAIN, NEW ARRAY POINTED TO BY A, OLD BY C +;PARRYS IS NOT CONSISTANT YET + ADD #PROINC,PARRYF ;ADD SOME SPACE TO THE FREE COUNT + MOV C,B ;COPY POINTER TO OLD ARRAY + MOV A,F ;COPY POINTER TO THE NEW ARRAY + ADD #PROTYP,F ;POINT TO THE START OF THE INFO IN THE NEW ARRAY + ADD #PROTYP,B ;POINT TO THE START OF THE INFO IN THE OLD ARRAY + SUB B,E ;GET THE BYTE COUNT FROM BOTTOM TO INSERTED AREA + BEQ TOPPRT ;NO BYTES BELOW AREA, MOVE REST OF AREA UP + ASR E ;INTO A WORD COUNT +1$: MOV (B)+,(F)+ ;COPY UP THE BOTTOM OF THE ARRAY + SOB E,1$ ;ALL THE WORDS IN THE BOTTOM +TOPPRT: MOV F,10(P) ;CLOBBER THE STORED E ON THE STACK + SUB A,10(P) ;MAKE IT RELATIVE + ADD D,F ;SKIP D BYTES + MOV PROEND(C),E ;GET THE POINTER TO THE END OF THE ARRAY + ADD C,E ;MAKE IT UNRELATIVE AGAIN + SUB B,E ;SUBTRACT WHERE WE HAVE GOTTEN + BEQ SPADN2 ;DONE IF NO BYTES ABOVE THIS POINT + ASR E ;INTO A WORD COUNT +2$: MOV (B)+,(F)+ ;MOVE IT UP IN THE NEW ARRAY + SOB E,2$ ;FOR ALL THE WORDS IN THIS ARRAY +SPADN2: MOV A,@PARRYS ;UPDATE THE POINTER TO THE ARRAY + MOV (C),(A) ;SET UP BACK POINTER TO BINDING NODE + SUB A,F ;MAKE POINTER TO END RELATIVE AGAIN + MOV F,PROEND(A) ;SET IN POINTER TO THE END OF THE PROC + MOV C,B ;COPY POINTER TO THE OLD ARRAY + JSR PC,.RELES ;AND RELEASE IT + ADD @PARRYS,10(P) ;MAKE THE POINTER ON THE STACK ABSOLUTE AGAIN + BR SPADN1 ;AND FINISH UP +NOSPA: ERROR+NAS ;NOT ENOUGH ARRAY SPACE (MAYBE CHANGED TO NO STORAGE LEFT) + +NUFSPA: SUB D,PARRYF ;DECREASE THE AMOUNT OF FREE SPACE + BMI MAKBUG ;BUG IF IT GOES NEGATIVE + MOV @PARRYS,A ;POINT TO THE START OF THE ARRAY + MOV PROEND(A),B ;GET THE POINTER TO THE END OF THE ARRAY + ADD A,B ;MAKE IT NON RELATIVE + ADD D,PROEND(A) ;MAKE THE POINTER A LITTLE HIGHER + MOV B,A ;COPY IT + SUB E,A ;GET THE NUMBER OF BYTES TO COPY + BEQ SPADN1 ;NOTHING TO COPY + ASR A ;GET THE NUMBER OF WORDS TO COPY + MOV B,C ;POINTER TO THE TOP OF THE ARRAY + ADD D,C ;POINT TO THE RIGHT SPOT ABOVE THE ARRAY +MAKSP2: MOV -(B),-(C) ;COPY IT UP + SOB A,MAKSP2 + BR SPADN1 ;ALL DONE +MAKBUG: .BUG. + .SBTTL UTILITY - LOAD AND STORE +.LOADA: MOV A,B ;(A) -> A,,B + BR .LOAD +.LOADC: MOV C,B ;NODE ADDR IN C + ;NODE RETURNED IN A,B +.LOADB: +.LOAD: BIC #170000,B ;NODE ADDR IN B + ASL B ;NODE RETURNED IN A,B + ASL B + ADD #NODESP,B + MOV (B)+,A + MOV (B),B + RTS PC +.STORE: SPUSH C ;NODE ADDR IN C + BIC #170000,C + ASL C ;NODE IN A,B IS STORED AT C + ASL C + ADD #NODESP,C + MOV A,(C)+ + MOV B,(C) + SPOP C + RTS PC + +.STP2: ;SAME AS .STP1 EXCEPT STORE IN 2ND WORD OF NODE + SEC ;THEN RESULT OF ROL'S WILL BE TWO GREATER THAN .STP1 + BR .STP9 +.STP1: CLC ;STORE (A) IN FIRST WORD OF NODE AT C +.STP9: SPUSH C ;NODE ADDR IN C + BIC #170000,C + ROL C + ROL C + ADD #NODESP,C + MOV A,(C) + SPOP C + RTS PC + +.LDP2: SEC ;NODE ADDR IN C (TYPE FIELD =0) + BR .LDP9 ;LOAD 2ND WORD OF NODE INTO A +.LDP1: CLC ;SAME AS .LDP2 EXCEPT 1ST WORD +.LDP9: MOV C,A + BIC #170000,A + ROL A + ROL A + ADD #NODESP,A + MOV (A),A + RTS PC + +.LDP2I: MOV C,A ;SAME AS .LDP2 EXCEPT C WILL + BIC #170000,A ;CONTAIN ADDR OF NEXT NODE + ASL A + ASL A + ADD #NODESP,A + MOV (A)+,C + MOV (A),A + RTS PC + .SBTTL UTILITY - BINDING + ;INPUT: A=TYPE B=UOE POINTER + ; TOPS=0 OR TYPE+VALUE POINTER + ;OUTPUT: A - UCHANGED + ; B - EITHER UNCHANGED OR VALUE POINTER + ; C - POINTS TO BINDING NODE, EITHER + ; RELEVANT ONE OR LAST IN BINDING LIST + ; IF TOPS = 0, SKIPS IF BINDING FOUND + ; IF TOPS NOT = 0, TOPS WILL BE INSERTED + ; AS THE NEW VALUE POINTER (A NEW BINDING + ; NODE WILL BE ADDED IF NECESSARY) NEVER SKIPS. +.BINDL: TST TOPS + BEQ .BIND + PUSHS TOPS + CLR TOPS + JSR PC,.BIND + BEQ .BNDL2 + POPS TOPS + CLZ + RTS PC +.BNDL2L: POPS TOPS + SEZ + RTS PC + +.BIND: PUSH D + SPUSH B + SPUSH A + MOV B,A +BINDF1: MOV A,C + JSR PC,.LOADC + MOV A,D + BIC #7777,D + CMP (P),D + BEQ BINDF4 ;FOUND IT + BIT #7777,A + BNE BINDF1 + TST TOPS ;DIDNT FIND IT + BEQ BINDF2 ;SHOULD ONE BE CREATED? + SPOP A + MOV TOPS,B + JSR PC,GRBAD1 +BINDF5: POP D ;OLD B +BINDF3: SPOP D + SEZ + RTS PC + +BINDF2: POP A ;NO, DONT CREATE NODE + SPOP B + BR BINDF3 + +BINDF4: TST TOPS ;FOUND, CHANGE VALUE POINTER? + BEQ BINDF6 + MOV TOPS,A ;YES + DONT SKIP + JSR PC,.STP2 + POP A + BR BINDF5 + +BINDF6: POP A ;NO, LEAVE VALUE POINTER, BUT SKIP + SPOP D ;OLD B + SPOP D + CLZ + RTS PC + .UNBND: PUSH A ;ERASE TYPE (A) FROM UOE (B) + SPUSH B ;SKIP UNLESS NOT FOUND + SPUSH C + SPUSH D + MOV B,C +.UNB1: MOV C,D + MOV B,C + BIT #7777,C + BNE 1$ + JMP RETD +1$: JSR PC,.LOADC + MOV A,B + BIC #7777,A + CMP 6(P),A + BNE .UNB1 + MOV D,C + JSR PC,.LDP1 + BIC #7777,A + BIC #170000,B + BIS B,A + JSR PC,.STP1 + JMP SRETD + +.BINDF: +.BNDFS: MOV #FBIND,A ;SAME AS .BINDF EXCEPT DONT SWAPIN + JSR PC,.BINDL +BIF1: RTS PC + .SBTTL .INTRN!! +.GLOBL TF5 ;103 +.OBSCH: ;SAME AS .INTRN EXCEPT WONT INSERT IF ENTRY ISNT FOUND + ;(ALSO SEE UOBSCH ON NEXT PAGE) + CLR TF5 + BR OBSCH9 +.INTRN: ;(ALSO SEE UINTRN ON NEXT PAGE) + ;INPUT: TYPE IN A, LSTR IN "TOPS" + ;OUTPUT: IF TYPE IS UFUN OR SFUN, + ; SEARCH SYSTEM OBLIST FIRST. + ; IF FOUND THERE, RETURN THAT PTR IN B, + ; MAKING TYPE OF A TO "SFUN". + ; IF NOT FOUND THERE, AND IF A=UFUN, OR IF TYPE + ; IS > "UFUN", DO THE LOOKUP IN THE USER OBLIST. + ; RETURN WITH THE UOE PTR IN B. + ; DONT SKIP IF A NEW ONE HAD TO BE ADDED, + ; OR IF IN SEARCHING FOR AN SFUN + ; ONE WAS NOT FOUND. +;******* NOTE ******** +;A NEW UOE IS "TOTALLY USELESS" AND SO MUST BE PROTECTED FROM G.C. + MOV PC,TF5 +OBSCH9: PUSH A + SPUSH B + SPUSH C + MOV TOPS,C + CMP #UFUN,A ;IS TYPE SFUN OR UFUN + BLO INT2 ;NO + JSR PC,SSOL ;YES, SEARCH SYSTEM OBLIST + BEQ INT1 ;NOT THERE + MOV #SFUN,4(P) ;SET TYPE TO "SFUN" + BR INT5 + +INT1: CMP #SFUN,A ;IS A = TYPE SFUN + BEQ INT0 ;YES, DONE, DONT SKIP +INT2: JSR PC,HSSL ;NO, HASH TO AND SEARCH SUBLIST + BEQ INT3 ;NOT FOUND + +INT5: MOV B,2(P) + JMP SRETC ;FOUND ATOM + +INT3: TST TF5 ;NOT THERE, SHOULD IT BE ADDED + BEQ INT0 ;NO, RETURN AND DONT SKIP + SPUSH B ;SAVE WORD POINTER TO UHCT ENTRY TO SPLICE THIS INTO + MOV #LIST,A + MOV #ATOM,B + JSR PC,GRBAD ;CONS UP NEW LAST NODE + ; (STRANGE TYPE LEST GARBAGE COLLECT) + BIS #LIST,C + PUSHS C ;SAVE POINTER TO IT, ALSO FOR G.C. + MOV #ATOM,A + MOV TOPS,B + JSR PC,GRBAD2 ;CONS UP ATOM NODE; NEW BUCKET NODE PTS TO IT + MOV C,4(P) ;SO WILL B ON RETURN + POPS C ;THE POINTER TO THE NEW BUCKET NODE WITH LIST TYPE + BIC #LIST,C ;GET BACK POINTER TO NEW BUCKET NODE + MOV @(P),A ;GET THE ENTRY THAT WAS IN THE UHCT IN THIS SLOT + BIS #BUKTEL,A ;MAKE THE NEW POINTER POINT TO THE REST OF THE ENTRIES + JSR PC,.STP1 + BIS #BUKTEL,C ;MAKE THE POINTER A BUCKET POINTER + MOV C,@(P)+ ;PUT THE NEW POINTER INTO THE UHCT +INT0: JMP RETC + + +;"UNPURE" .INTRN AND .OBSCH +;BY "UNPURE" IT IS MEANT THAT THE INPUT STRING MAY INCLUDE +;NULL CHARACTERS +;SPECIFICATIONS ARE OTHERWISE IDENTICAL TO .INTRN AND .OBSCH + +;ROUTINE TO PURIFY STRING +UINOB: PUSH A + PUSH B + PUSH C + MOV TOPS,B + JSR PC,CPYSTR ;OUTPUT POINTER IN B TO STRING WITH NO NULLS + BIS #LSTR,B + MOV B,TOPS + POP C + POP B + POP A + RTS PC + +UINTRN: SPUSH #.INTRN + BR UINOB + +UOBSCH: SPUSH #.OBSCH + BR UINOB + .SBTTL SEARCH SYSTEM OBLIST +.GLOBL ABRFLG,SOBP2,SOOMX ;105 +.GLOBL HCC,UHCT ;106 +SSOL: ;SEARCH SYSTEM OBLIST + ;INPUT: C POINTS TO STRING + ;OUTPUT: SKIP = FOUND AND SOE PTR IN B + ; NO SKIP = NOT FOUND AND NO CHANGE + ;NULL MUST BE USED AS FILLER CHAR BUT NOT BE IMBEDDED + PUSH A + SPUSH B + SPUSH C ; -> STRING (DESIRED PNAME) + SPUSH D ; -> CURRENT PNAME + SPUSH E ; 2^N + SPUSH F ; -> SYSTEM OBLIST ELEMENT + MOV SOBP2,E ;GET 2^N + MOV #SOBLST,F ;GET START OF OBLIST +SSOL1: ASR E ;HALVE 2^N + BIT #177776,E ;NOT FOUND IF 2^N = 1 + BEQ SSOL5 + ADD E,F ;ADD 2^N TO OBLIST PTR + CMP F,SOOMX ;OVERSHOT END OF LIST THEN UNDO ADD + BHIS SSOL2 + MOV (F),D + ADD #4+SOBLST,D ;FIND START OF THIS PNAME + MOV C,A ;AND DESIRED PNAME +SSOL4: JSR PC,.LOADA ;GET TWO CHARS OF DESIRED + CMPB B,(D)+ + BHI SSOL1 ;PNAME < DESIRED: ADD 2^(N-1) + BLO SSOL2 ;PNAME > DESIRED: UNADD 2^N AND ADD 2^(N-1) + SWAB B + CMPB B,(D)+ + BHI SSOL1 ;PNAME < DESIRED + BLO SSOL2 ;PNAME > DESIRED + BIT #7777,A ;MORE PNAME TO COMPARE? + BNE SSOL4 ;YES + TSTB B ;MATCHING NULLS FOUND? + BEQ SSOL3 ;FOUND + TSTB (D) ;AT END OF STRING, IS IT END OF SYS PNAME + BNE SSOL2 ;NO: TRY ANOTHER (COUNT AS OVERSHOOT) +SSOL3: MOV (F),F ;POINTER TO OBLIST ELEMENT + .IFNZ ENG&FR + BIT LANG,SOBLST(F) + BEQ SSOL5 + .ENDC + BIT #ABRFLG,SOBLST(F) ;IS IT AN ABBRVIATION? + BEQ 1$ + MOV 2+SOBLST(F),F ;YES, "EXPAND" IT +1$: ASR F + MOV F,10(P) ;YES, SAVE F AS OUTPUT + JMP SRETF + +SSOL5: JMP RETF + +SSOL2: SUB E,F ;UNADD 2^N + BR SSOL1 + .SBTTL HASH AND SEARCH USER SUB-OBLIST +HSSL: ;HASH, THEN SEARCH SUB-LIST + ;INPUT: C POINTS TO LSTR + ;OUTPUT: IF NOT FOUND, B IS A WORD POINTER + ; TO THE UHCT ENTRY TO SPLICE IT INTO + ; IF FOUND, B POINTS TO ATOM CELL, AND RETURN SKIPS. + PUSH A + SPUSH B ;PTR TO THIS PNAME + SPUSH C ;PTR TO DESIRED PNAME + SPUSH D ;NEXT OLE + SPUSH E ;THIS OLE + MOV C,A ;PTR TO STRING + CLR D ;SUM OF WORDS FOR HASHING +HSSLA: JSR PC,.LOADA ;GET A TWO-LETTER FRAGMENT + ADD B,D ;ADD IN + BIT #7777,A ;MORE FRAGMENTS? + BNE HSSLA ;YES + MOV D,B ;CREATE SUM OF ALL CHARS + SWAB B + ADD D,B ;IN LOWER BYTE (UPPER WON'T HURT) + CLR A + DIV #HCC,A + ASL B + ADD #UHCT,B + MOV B,-(P) ;SAVE THE POINTER TO THE UHCT ENTRY TO SPLICE IT INTO + MOV (B),A ;A POINTS TO FIRST OLE NOW +HSSL1: BIT #7777,A ;END OF BUCKET? + BNE HSSLB + MOV (P)+,6(P) ;YES: NOT-FOUND RETURN: + JMP RETE ;OUTPUT POINTER TO THE UHCT TO SPLICE IT INTO + +HSSLB: MOV A,E ;SAVE PTR TO THIS OLE + JSR PC,.LOADA ;GET THIS OLE + MOV A,D ;SAVE PTR TO NEXT ONE + JSR PC,.LOADB ;GET FIRST NODE OF ATOM STRUCTURE + JSR PC,CSEQ ;CSEQ COMPARES STRINGS AT (B) AND (C) + BEQ HSSL2 ;NOT EQUAL: TRY NEXT OLE + MOV E,A ;EQUAL: + JSR PC,.LOADA ;OUTPUT ATOM POINTER + TST (P)+ ;POP OFF THE UHCT POINTER + MOV B,6(P) + JMP SRETE ;SKIP RETURN + +HSSL2: MOV D,A ;NOT FOUND, CHECK NEXT BUCKET ELEMENT + BIC #LIST,E ;MAKE E A WORD PTR TO FIRST WORD OF PREV. NODE + ASL E ;IN CASE IT'S THE LAST ONE. + ASL E + ADD #NODESP,E + BR HSSL1 + CSEQ: PUSH A ;COMPARE TWO STRINGS - POINTERS IN B & C + PUSH B ;SKIP IF EQUAL + PUSH C ;"NULL" (8-BIT ON) CHARACTERS + PUSH D ; DON'T MATCH CORRESPONDING 8-BIT OFF CHARS + MOV B,D ;SAVE STR 1 PTR +CSEQ1: BIT #7777,D ;CHECK IF EITHER STRING DONE + BEQ CSEQ3 ;FIRST IS: IS SECOND? + BIT #7777,C + BEQ CSEQ2 ;SECOND BUT NOT FIRST: NOT EQUAL + MOV D,A + JSR PC,.LOADA ;GET NEXT NODE OF STR 1: (A) TO A,,B + MOV A,D ;SAVE POINTER IN D + JSR PC,.LDP2I ;GET NEXT NODE OF STR 2: (C) TO C,,A + CMP A,B + BEQ CSEQ1 ;WELL, THESE WORDS MATCH +CSEQ2: JMP RETD ;STRINGS NOT EQUAL + +CSEQ3: BIT #7777,C ;SEE IF BOTH STRINGS ARE DONE + BNE CSEQ2 ;NOPE, NOT EQUAL + JMP SRETD ;STRINGS EQUAL + .SBTTL UTILITY - GRAB NODE ROUTINES +.GLOBL FREE,NNIFSL ;108 +GRBAD2: SEC ;GRAB A FREE NODE, FILL IT WITH A,,B + ;IF C NOT =0, PUT PTR TO NEW NODE IN WORD 2 OF NODE(C) + ;C ALSO GETS POINTER TO NEW NODE REGARDLESS + BR GRBAD9 +GRBAD: CLR C ;SAME AS ABOVE EXCEPT NEW POINTER ALWAYS IN C +GRBAD1: CLC ;SAME AS ABOVE EXCEPT NEW PTR IN WORD 1 +GRBAD9: SPUSH A + BIC #170000,C + BEQ GRB2 ;C IS ZERO, FORGET STORING NEW NODE PTR + ROL C + ROL C + ADD #NODESP,C ;ELSE MAKE NODE ADDRESS TO STORE AT +GRB2: BIT #MGCF,FLAGS2 + BNE GRB4 + MOV FREE,A + BNE GRB1 +GRB4: JSR PC,.GCOLL + MOV FREE,A + BNE GRB1 + CLR ERPROC ;DISABLE ERRSET IF 0 NODES + ERROR+NSL ;NO STORAGE LEFT +GRB1: DEC NNIFSL + BGE 1$ ;NEG NODES LEFT?? + .BUG. +1$: TST C + BEQ GRB3 + BIC #170000,A + BIC #7777,(C) + ADD A,(C) +GRB3: MOV A,C + JSR PC,.LDP1 +; SPUSH A ;CHECK THAT NODE WAS IDLE +; BIC #7777,A +; CMP #IDLE,A +; BEQ 1$ +; .BUG. ;GRABBED AN UNIDLE NODE!!!!! +;1$: SPOP A + BIC #170000,A + MOV A,FREE + SPOP A + JSR PC,.STORE + RTS PC + ;.SBTTL UTILITY - FREE NODE ROUTINES +.FREE: SPUSH A ;RETURN NODE IN C TO FREE STORAGE + SPUSH B + MOV FREE,A + BIS #IDLE,A + CLR B ;MAKE SURE POINTER 2 IS ZERO + JSR PC,.STORE + BIC #170000,C + MOV C,FREE + INC NNIFSL + SPOP B + SPOP A +.FREE1: RTS PC +FRELST: BIT #7777,TOPS ;RETURN LIST (TOP-LEVEL ONLY) IN TOPS + ;TO FREE STORAGE + BEQ .FREE1 + PUSH A + SPUSH B + SPUSH C + MOV TOPS,C +FRL1: JSR PC,.LOADC + JSR PC,.FREE + BIT #7777,A + BEQ FRL2 + MOV A,C + BR FRL1 +FRL2: CLR TOPS + JMP RETC + .SBTTL READ A STRING +.GLOBL DRIBF,GCHR,RBRKF,TYI,TYO ;110 +.GLOBL GETCNO,GNCN ;111 + +RDSTR7: MOV PC,RBRKF + SEZ +RDSTR8: RTS PC +RDSTR1: PRCR ;OUTPUT - PTR ON S, SKIP UNLESS EMPTY OR BREAK +RDSTR: CLR NBKTS + TST BRAKE + BNE RDSTR7 + CMP #TYI,GCHR ;WILL CHARS BE COMING FROM TTY? + BNE RLINE1 ;NO + TST BRAKE + BEQ 1$ + ERROR+BRK +1$: MOV PRMTCH,D + BEQ RLINE + BIT #BRKF,FLAGS + BEQ RLINE2 + MOV FUNLEV,A + BEQ RLINE2 +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + JSR PC,TYO + JSR PC,PRDN + MOV PRMTCH,D +RLINE2: JSR PC,TYO +RLINE: +RLINE1: JSR PC,BLSTI +RDSTR2: JSR PC,@GCHR + CMP #TYI,GCHR + BNE RDST69 +RDST2A: JSR PC,@DRIBF ;DRIBLE IT OUT IF DRIBBLING +RDST69: TST BRAKE + BNE RDSTR7 + CMP #TYI,GCHR + BEQ RDSTR9 + BIT #FILRED,@FILFLP + BNE RDSTR9 + MOV #TYI,GCHR ;NON-TTY INPUT DONE + MOV #'],D ;FILL IN MISSING ]'S + TST NBKTS +RDSR10: BLE RDSTR4 + JSR PC,BLST + DEC NBKTS + BR RDSR10 +RDSTR9: CMP #TYI,GCHR ;READING FROM TTY? + BNE 1$ ;NOPE + CMP #'G-100,D ;BREAK TYPED? + BEQ RDSTR7 ;YES + CMP #'Z-100,D + BEQ RDSTR7 +1$: TST NBKTS ;IN A LIST? + BGT RDSTR3 ;YES + CMP #15,D ;CR? + BEQ RDSTR4 +RDSTR3: CMP #'[,D + BNE RDSTR6 + INC NBKTS +RDSTR6: CMP #'],D + BNE RDSTR5 + DEC NBKTS +RDSTR5: JSR PC,BLST + BR RDSTR2 +RDSTR4: CLR RBRKF + JSR PC,BLSTF + BEQ RDSTR8 + PUSHS TOPS + CLR TOPS +RDSTSR: CLZ + RTS PC + + .SBTTL REQUEST, FILE READ & WRITE +RQUEST: +RQU1: PUSH PRMTCH + JSR PC,INPUTL + BEQ RQU5 + MOV E,C ;E POINTS TO LAST NODE OF STRING + JSR PC,.LOADC ;NEED TO ADD A "]", IS THERE ROOM? + BIT #177400,B + BNE RQU2 ;YES + BIS #']*400,B ;NO - PUT A "]" THERE + JSR PC,.STORE +RQU3: MOV @S,GNCN + BIC #170000,GNCN + CLR F ;THIS IS PUSHED BY RDLST + JSR PC,RDLST + POPS TOPS +RQU4: MOV TOPS,@S + CLR TOPS +RQUR: POP PRMTCH + CLZ + RTS PC +RQU2: MOV #'],B + JSR PC,GRBAD1 + BR RQU3 +RQU5: MOV #LIST,@S + BR RQUR +INPUTL: MOV #'<,PRMTCH + JSR PC,GETCNO ;LAST INST OF GET CNO IS MOV (P)+,B SO FLAGS ARE SET + BEQ 1$ + CLR PRMTCH +1$: JSR PC,RDSTR + BNE IPUL2 +IPUL1: TST RBRKF + BEQ IPUL3 + TST (P)+ + SPOP PRMTCH ;NOW THE OLD PRMTCH + ERROR+BRK +IPUL3: PUSHS #LSTR + SEZ +IPUL2: RTS PC +TYPEIN: JSR PC,RQU1 ;INPUT A WORD FROM TTY + BIT #7777,@S + BNE TYPIN2 + MOV #LSTR,@S + RTS PC +TYPIN2: JMP FIRST + .SBTTL READ - +.GLOBL COP,DTBL,DTBL2,OPERF,RDFLAG,SEPF,SOBLSU ;112 +.GLOBL NNUMF ;113 +.GLOBL LISTBD ;114 +.GLOBL $DOTS ;115 +.GLOBL NCHR ;116 + +READ: PUSH A + SPUSH B + SPUSH C + SPUSH D + SPUSH E + SPUSH F + CLR RDFLAG + MOV @S,GNCN + BIC #170000,GNCN + CLR F +READA: JSR PC,RDWRD + BEQ READB + BIS #SEPF,RDFLAG + JSR PC,CKDOTF +READC: JSR PC,LISTB + BIT #SEPF,RDFLAG + BEQ READA +READB: BIC #SEPF,RDFLAG ;CHECK SPECIAL CHAR IN D + JSR PC,CKDOTF ;FIRST CHECK FOR PENDING ":" + CMP #15,D + BEQ READR ;C-R + CMP #'",D + BEQ READS ;STRING + CMP #'[,D + BEQ READL ;LIST + CMP #'],D + BNE 1$ + ERROR+COP ;CHAR (]) OUT OF PLACE +1$: CMP #':,D + BEQ READD ;DOTS + BITB #OPERF,DTBL(D) ;IS CHAR AN OPERATOR + BEQ READA ;NO + MOVB DTBL2(D),A + ASL A + MOV SOBLSU(A),B + ;SET TYPE TO SFUN OR INFIX + MOV SOBLST(B),A ;THIS CROCK WORKS BECAUSE #SFUN=0 + BIC #-INFIX-1,A ; AND #INFIX=10000 + ASR B + BIS A,B ;SET IN THE TYPE (IF INFIX) + BR READC + +READR: POPS A + CLR TOPS + TST F + BNE READR1 + JMP RETF +READR1: MOV A,@S + JMP SRETF + +READS: JSR PC,GNC + JSR PC,RDST + BIS #SEPF,RDFLAG + BR READC +READL: JSR PC,RDLST + POPS TOPS + BIC #SEPF,RDFLAG + BR READC +READD: BIS #DOTF,RDFLAG + BR READA + .SBTTL READ - READ WORD + ;READ CHARS UP THRU NEXT SEPARATOR CHAR. IF JUST A SEP, RETURN + ;WITH IT IN D. OTHERWISE NUMBERIFY OR INTERN CHAR STRING, + ;SKIP RETURN WITH TOKEN IN A,,B +RDWRD: CLRB RDFLAG + JSR PC,BLSTI +RDWA: JSR PC,GNC + JSR PC,GETCHF ;GET FLAGS IN A + BIT #SEPF,A ;IS THIS CHAR A SEPARATOR? + BNE RDWB ;YES + BISB A,RDFLAG + JSR PC,BLST + BEQ RDWA +RDWB: JSR PC,BLSTF ;FINISH OFF STRING + BEQ RDWR+2 + BIT #NNUMF,RDFLAG + BNE RDWC ;NOT A POSSIBLE NUMBER + MOV TOPS,B + MOV #LNUM,A + JSR PC,CONVER ;TRY MAKING A # +.IFNZ FPPF + BNE RDWR1 + MOV #FNUM,A + JSR PC,CONVER ;IT MIGHT BE AN FNUM +.ENDC + BNE RDWR1 +RDWC: MOV #UFUN,A ;TRY TO INTERN STRING IN TOPS AS A SYSTEM OR USER FUNCTION + BIT #DOTF,RDFLAG ; UNLESS DOTF ON, THEN AS USER VARIABLE + BEQ RDWD + MOV #UVAR,A + BIC #DOTF,RDFLAG +RDWD: JSR PC,.INTRN ;RDST COMES HERE ALSO + BEQ RDWE + JSR PC,FRELST +RDWE: BIC #170000,B + BIS A,B + CMP #UFUN,A ;IF WE GOT A UOE + BHI RDWR+2 ;THEN-- +RDWR1: MOV B,TOPS ;PROTECT THIS NEWLY HATCHED UOE FROM G.C. +RDWR: CLZ + RTS PC + +GETCHF: ;GET FLAGS FOR CHAR IN D INTO A + MOV #NNUMF,A + TSTB D ;CHECK FOR 200 BIT + BLT 1$ + MOVB DTBL(D),A +1$: RTS PC + .SBTTL READ - READ STRING + ;READ CHAR UP TO NEXT SPACE OR ] IF INSIDE + ;A LIST. DONT ALLOW ] OR [. + ; SKIPS UNLESS EMPTY STRING +RDST: CLRB RDFLAG + JSR PC,BLSTI + BR RDSB +RDSA: JSR PC,GNC +RDSB: JSR PC,GETCHF + BIT #SEPF,A + BEQ RDSE + JSR PC,SPACHK + BEQ RDSX + CMP #'],D + BEQ RDSC + CMP #'[,D + BEQ RDSX + CMP #15,D + BEQ RDSX +RDSE: BISB A,RDFLAG + JSR PC,BLST + BR RDSA +RDSC: TST LISTBD ;ARE WE IN LIST + BNE RDSX ;YES +RDSD: ERROR+COP ;CHAR (D) OUT OF PLACE +RDSX: MOV #LSTR,A + MOV #LSTR, B + JSR PC,BLSTF + BEQ RDWR+2 + MOV #LSTR,A + MOV TOPS,B + BIT #NNUMF,RDFLAG + BEQ RDWR ;IT IS A POSSIBLE NUMBER + BIT #SEPF,RDFLAG + BNE RDWR+2 ;IT HAS A SEP CHAR IN IT + MOV #ATOM,A + BR RDWD ; INTERN IT + +SPACHK: CMP #' ,D ;SPACE? + BEQ 1$ ;YUP + CMP #11,D ;TAB? +1$: RTS PC + + ;READ THRU MATCHING ] MAKING A LIST AS U GO +RDLST: CLRB RDFLAG + JSR PC,SLISTB +RDLA: JSR PC,GNC + JSR PC,SPACHK ;IS IT SPACE OR TAB? + BEQ RDLA ;SKIP OVER SPACES + CMP #'[,D + BEQ RDLB ;READ A LIST + CMP #'],D + BEQ RDLY ;DONE + JSR PC,RDST ;READ A STRING +RDLX: JSR PC,LISTB ;ADD THIS NODE TO LIST + CMP #'[,D + BEQ RDLB + CMP #'],D ;AT END? + BNE RDLA ;NO, GET NEXT ELEMENT +RDLY: JSR PC,FLISTB + RTS PC +RDLB: JSR PC,RDLST + POPS TOPS + CLR D + BR RDLX + .SBTTL READ - MISC +CKDOTF: BIT #DOTF,RDFLAG + BEQ LISTBR + BIC #DOTF,RDFLAG + PUSH A + SPUSH B + MOV #SFUN,A + MOV #$DOTS,B + JSR PC,LISTB + JMP RETB +LISTB: PUSH C + MOV F,C ;BUILD A LIST, ADD NODE IN A,,B TO + JSR PC,GRBAD1 ;LIST WHOSE LAST NODE PTR IS IN F + TST F ;CAREFUL - THE FIRST TIME IT IS CALLED, THE + ;POINTER TO THE FIRST NODE IS PUSHED ONTO S + BNE LISTB1 + PUSHS C + BIS #LIST,@S +LISTB1: MOV C,F + POP C +LISTBR: RTS PC +SLISTB: ;START LISTB + PUSHS F ;SAVE CURRENT LAST NODE PTR + CLR F + INC LISTBD + RTS PC +FLISTB: TST F + BNE FLSB1 + PUSHS #LIST +FLSB1: POPS B ;THIS IS THE OUTPUT + MOV @S,F ;RESTORE OLD LAST NODE PTR + MOV B,@S ;THE RESULT + MOV #LIST,A + DEC LISTBD + RTS PC + BLSTI: CLR NCHR + MOV #100000,E + JMP CLRTOP + +BLST: ;BUILD STRING - CHAR IN D, USES E + PUSH A + SPUSH B + SPUSH C + BIT #377,D ;CHECK IF NULL + BEQ BLSTRT + INC NCHR ;WE HAVE A CHAR + ADD #40000,E + BGE BLST2 ;IS IT THE SECOND + MOVB D,TEMP ;NO, 1ST +BLSTRT: JMP RETC +BLST2: MOVB D,TEMP+1 ;IT IS THE SECOND CHAR + MOV TEMP,B + ;STORE THE CHARACTERS + JSR PC,BSAN + BIS #100000,E + BR BLSTRT +BLSTF: ;FINISH BUILDING STRING, PUT PTR IN TOPS. + ; DONT SKIP IF EMPTY STRING (TOPS=0) + TST NCHR + BEQ BSANR ;EMPTY STRING + ADD #40000,E + BLT BSANR + PUSH A + SPUSH B + SPUSH C + MOVB TEMP,B ;YES + BIC #177400,B + JSR PC,BSAN + JMP SRETC +BSAN: MOV E,C + MOV #SSTR,A + JSR PC,GRBAD1 + TST E + BNE BSAN1 + MOV C,TOPS ;SAVE NEW STRING PTR ON S + BIS #LSTR,TOPS +BSAN1: MOV C,E +BSANR: RTS PC + .SBTTL GNC - GET NEXT CHAR +GNC: PUSH A ;GET NEXT CHAR INTO D + SPUSH B ;INITIALIZE BY MOVING LSTR PTR INTO GNCN +GNC4: MOVB GNCN+2,D ; AND CLEARING TYPE FIELD (#170000) + MOV GNCN,B ;PUTS CR (=#15) IN D IF NO MORE CHAR + BLT GNC1 ;JUST GOT 2ND CHAR + BNE GNC3 + MOV #15,D + JMP RETB ;NONE LEFT +GNC3: JSR PC,.LOAD ;GET NEXT NODE + BIS #100000,A ;SET "STILL ANOTHER CHAR" BIT + MOV A,GNCN + MOVB B,D ;FOR OUTPUT + SWAB B + MOVB B,GNCN+2 +GNC2: TST D + BEQ GNC4 ;IGNORE NULL CHARS + JMP RETB +GNC1: BIC #170000,GNCN ;CLEAR "STILL ..." BIT + BR GNC2 + .SBTTL PRINT ROUTINES + +PRLO: PUSH A ;PRINT LAST OPERATOR + SPUSH B + MOV LO,A + BEQ EMPTY + MOV A,B + BR PRCO1 +PRCO: PUSH A, ;PRINT CURRENT OPERATOR + SPUSH B + MOV CO,A + MOV A,B + BEQ EMPTY +PRCO1: SPUSH D + JSR PC,PROAB + SPOP D + JMP RETB +PROAB: CMP A,#UFUN ;PRINT OPERATOR IN A,B + BLO PRCO2 + JMP PPNAME ;PRINT PNAME +PRCO2: MOV B,A ;SYSTEM FUNCTION + BNE PRCO3 + PRTXT ^\ CR.\ + RTS PC +PRCO3: + BIC #170000,A ;CLEAR OUT THE INFIX TYPE + ASL A + ADD #4+SOBLST,A + BR PRAS ;PRINT ASCIZ PNAME +NOTPRO: ERROR+OOP ;SOMETHING OUT OF PLACE + EMPTY: PRTXT ^\ EMPTY \ + JMP RETB +.GLOBL GETAML +ERTAS: SPUSH D +1$: SAVE A + JSR PC,GETAML + MOVB A,D + BEQ 2$ + JSR PC,@PCHR + SWAB A + MOVB A,D + BEQ 2$ + JSR PC,@PCHR + REST A + ADD #2,A + BR 1$ +2$: REST + ADD #2,A + RTS A + + +PRAS: SPUSH D ;PRINT ASCIZ STRING POINTED TO BY A + BR PRAS9 +PRAS1: JSR PC,@PCHR +PRAS9: MOVB (A)+,D + BNE PRAS1 + SPOP D + RTS PC + ;GENERAL PRINT NUMBER ROUTINE +;CALL WITH A CLEAR, NUMBER TO BE PRINTED IN B +;MINIMUM NUMBER OF DIGITS TO PRINT IN C +;AND RADIX TO PRINT IN (=< 10.) IN D +PRN: DIV D,A + SAVE + MOV A,B + CLR A + DEC C + BGT PRN + TST B + BNE PRN + RTS PC ;RETURN TO PRNDIG + +PRNDIG: REST D ;DIGIT TO PRINT + ADD #60,D + JMP @PCHR + +;PRINT A DECIMIAL NUMBER IN B WITH AT LEAST 2 DIGITS +ZPRDN: SAVE C + MOV #2,C ;AT LEAST 2 DIGITS + BR PRDN2 + +PRDN: SAVE C + CLR C +PRDN2: SAVE + MOV A,B ;NEGATIVE? + BGE 1$ + NEG B + MOV #'-,D + JSR PC,@PCHR +1$: MOV #10.,D + CLR A +PRDN1: JSR PC,PRN + REST + RTS PC + +PRON: SAVE C + CLR C + BR PRONL1 + +PRONL: SAVE C + MOV #6,C +PRONL1: SAVE + MOV A,B + CLR A + MOV #8.,D + BR PRDN1 + +EMPTY1: JMP EMPTY + +.GLOBL INVN ;121 +.GLOBL WRTFLG ;122 +PRS1: PUSH A ;PRINT TOP ELEMENT OF SS + SPUSH B + MOV IS,A ;COMPUTE RELATIVE S PD PTR + SUB S,A + ADD SPRBAO,A + CMP A,CSPDLP + BLOS EMPTY1 + MOV @S,B + SPUSH D + JSR PC,PNODAB + SPOP D + JMP RETB +PNODAB: MOV B,A + BIC #7777,A + CMP #SSTR,A + BEQ PRS11 + CMP #SNP,A + BLOS PRS11 + ERROR+INVN ;INVALID NODE +PRS11: JSR PC,PRDATA + RTS PC +PRCT: PUSH A ;PRINT CURRENT TOKEN + SPUSH B + SPUSH D + MOV CT,A + MOV A,B + JSR PC,PRTAB + SPOP D + JMP RETB +PRTAB: BIC #7777,A ;PRINT TOKEN IN A,B + CMP A,#UVAR + BHIS 1$ + JMP PROAB +1$: CMP A,#UVAR + BEQ PRUV + BR PRDATA + PRUV: MOVB #':,D ;PRINT USER VARIABLE IN A,B + JSR PC,@PCHR +PPNAME: BIC #PQF,FLAGS2 ;PRINT PNAME - UOE PTR IN B +PRUV1: JSR PC,.LOAD + JMP PRLSTR ;PRINT PNAME +PRDATA: CMP #INUM,A ;PRINT DATA IN A,B. 7777 FIELD OF A IS 0000 + BEQ PRINUM ;NUMBER +.IFNZ FPPF + CMP #FNUM,A + BEQ PRFNUM +.ENDC + CMP #SNUM,A + BEQ PRSNUM + BIS #PQF,FLAGS2 ;SET PRINT QUOTE FLAG +PRPNM1: CMP #ATOM,A + BEQ PRUV1 + CMP #LSTR,A + BEQ PRLSTR ;LONG STRING + CMP #SSTR,A + BEQ PRSSTR ;SHORT STRING + BIC #PQF,FLAGS2 + CMP #LIST,A + BEQ PRLST + TST WRTFLG + BEQ PRSNP ;YES + PRTXT ^/" / ;OUTPUT EMPTY + BR PRSRET +PRSNP: PRTXT ^\%SNAP%\ ;CANT PRINT A SNAP + BR PRSRET +PRLSTR: JSR PC,.LOAD ;PRINT LONG STRING +PRSSTR: JSR PC,PRQQ ;PRINT SHORT STRING +PRSTR2: MOVB B,D + JSR PC,PRSPT + SWAB B + MOVB B,D + JSR PC,PRSPT + MOV A,B + BIC #170000,B + BEQ PRSRET + JSR PC,.LOAD + BR PRSTR2 +PRSRET: RTS PC +PRQQ: BIT #PQF,FLAGS2 ;PRINT ' " ' IF PQF=1 + BEQ PRSRET + BIT #DPQF,FLAGS2 + BNE PRSRET + MOVB #'",D + JMP @PCHR + .IFNZ FPPF +PRFNUM: PUSH C + JSR PC,.FLOAD + MOV #FNUM,C + BR PRFNM1 +.ENDC +PRSNUM: CLR A ;PRINT SNUM + TST B + BGE PRINM1 + COM A + BR PRINM1 +PRINUM: JSR PC,.LOAD ;PRINT INUM +PRINM1: PUSH C +.IFNZ FPPF + MOV #INUM,C ;SET FLAG FOR INUM ENTRY +.ENDC +PRFNM1: MOV E,TMPBLK+2 + MOV F,TMPBLK+4 +.IFNZ FPPF + CMP #FNUM,C + BNE 1$ + JSR PC,.CFNST + BR 2$ +1$: +.ENDC + JSR PC,.CINST ;CONVERT INUM IN A,,B TO STRING ON P +2$: MOV TMPBLK+2,E + MOV TMPBLK+4,F + MOV P,A + MOVB (A)+,D + BNE PRINM3 +PRINM2: MOVB (A)+,D + BEQ PRINM4 +PRINM3: JSR PC,@PCHR + BR PRINM2 +PRINM4: INC A ;TO MAKE IT EVEN (??) + MOV A,P + POP C +PRSPT2: RTS PC + +PRSPT: TSTB D + BEQ PRSPT2 + BIT #CPTBF,FLAGS2 + BEQ PRSPT1 + CMPB #'%,D + BNE PRSPT1 + MOV #' ,D +PRSPT1: JMP @PCHR + PRLST: PUSH A ;PRINT LIST, PTR IN B + SPUSH B + SPUSH C + TST NBKTS + BEQ PRL4 + MOV #'[,D + JSR PC,@PCHR +PRL4: INC NBKTS + MOV B,C +PRL1: SPUSH FLAGS2 + BIT #7777,C ;EMPTY LIST + BEQ PRL2 ;YES, DONE + BIS #DPQF,FLAGS2 ;DONT PRINT QUOTE BEFORE STRINGS + BR PRL3 +PRL6: SPACE +PRL3: JSR PC,.LOADC ;GET THIS NODE + MOV A,C ;SAVE PTR TO NEXT + BIC #7777,A + JSR PC,PRTAB + BIT #7777,C + BNE PRL6 +PRL2: DEC NBKTS + BEQ PRL5 + MOV #'],D + JSR PC,@PCHR +PRL5: BIC #DPQF,FLAGS2 + SPOP C ;GET OLD FLAGS2 + BIC #<-DPQF-1>,C ;MASK ALL BUT DPQF + BIS C,FLAGS2 ;AND RESTORE IT + JMP RETC + + + .SBTTL PRINTOUT (ONCE KNOWN AS SHOW) +.GLOBL PODISP,SHW ;125 +.GLOBL $DISPL,$PLOTT,$STTUR,ASSTPL,ASSTUR,ASTRDI,CTRDIS,CTRPLT,CTRTUR ;126 +.GLOBL .POF ;127 +SHALPR: ;SHOW ALL PROCEDURES + ;USES A-F + JSR PC,GNOLEI + BR SHALP2 +SHALP1: JSR PC,.CRLF +SHALP2: JSR PC,GNOLE + BEQ SHOWA1 + JSR PC,BURYQX + BEQ SHALP2 + JSR PC,PSHOW + BNE 1$ + .BUG. +1$: CMP PCHR,#TYO + BNE SHALP2 + BR SHALP1 + +POTS: +SHALTI: ;SHOW ALL TITLES + JSR PC,GNOLEI +SHATI1: JSR PC,GNOLE + BEQ SHOWA1 + JSR PC,BURYQX + BEQ SHATI1 + JSR PC,SHTITL + BR SHATI1 + +SHOWAL: JSR PC,SHALPR ;SHOW ALL PROCEDURES + JSR PC,SHALNA ;SHOW ALL NAMES + TST WRTFLG ;DON'T SHOW ARRAYS ON WRITE + BNE SHOWA1 + JSR PC,POARR ;SHOW ALL ARRAYS +SHOWA1: SEZ + RTS PC + +SHOW: + TST CLCNT ;ANY TOKENS LEFT + BNE SHOW00 ;YEP + MOV TOPRNM,B + BNE SHOW0 + MOV LASTPR,B + BNE SHOW0 + ERROR+SHW + +SHOW00: JSR PC,GTUOEB + BNE SHOW1 ;THE TOKEN ISNT A USER PROC +SHOW0: JSR PC,PSHOW + BNE SHOWA1 + ERROR+PNH ;PROCEDURE NOT HERE +SHOW1: CMP #SFUN,A + BNE SHOWE1 + TST B ;IS IT CR? + BNE SHOW12 ;NO + MOV TOPRNM,B + BNE SHOW0 +SHOWE1: ERROR+SHW + +SHOW12: MOV #PODISP,A +SHOW13: CMP (A)+,B + BNE SHOW23 + JMP @(A) +SHOW23: TST (A)+ + TST (A) + BNE SHOW13 + ERROR+SHW + +.IFNZ DDF +CNTRL: CLR C + INC C + BR ALSO2 +ALSO: CLR C +ALSO2: BIT #7777,CT + BNE ALSOW1 +ALSOWH: ERROR+WTAB +ALSOW1: JSR PC,GNT + BIC #7777,A + CMP #SFUN,A + BNE ALSOWH + TST B + BEQ ALSOWH +.IFNZ ENG + CMP #$STTUR,B + BEQ TUR +.IFNZ NDISP + CMP #$DISPLAY,B + BEQ DIS +.ENDC +.IFNZ NPLOT + CMP #$PLOTTER,B + BEQ PLOT +.ENDC +.ENDC +.IFNZ FR + CMP #$TORTUE,B + BEQ TUR +.IFNZ NDISP + CMP #$ECRAN,B + BEQ DIS +.ENDC +.IFNZ NPLOT + CMP #$TRACEUR,B + BEQ PLOT +.ENDC +.ENDC + BR ALSOWH +.IFNZ NDISP +DIS: TST C + BEQ 1$ + JMP CTRDIS +1$: JSR PC,EVAL + BEQ TUR2 + JMP ASTRDI +.ENDC +TUR: TST C + BEQ TUR1 + JSR PC,EVAL + BEQ TUR2 + JMP CTRTUR +TUR1: JSR PC,EVAL + BNE TUR69 +TUR2: ERROR+WTAB +TUR69: JMP ASSTUR +.IFNZ NPLOT +PLOT: TST C + BEQ 1$ + JMP CTRPLT +1$: JMP ASSTPL +.ENDC +.ENDC + +POT: MOV TOPRNM,B ;SHOW THIS TITLE + BEQ POL1 + JSR PC,SHTITL + BNE POL2 + .BUG. + +POL: TST TOPRNM + BNE POL69 +POL1: ERROR+OIP +POL69: JSR PC,GTLN ;GEN LINE NO. FROM NEXT TOKEN INTO B + BNE 1$ + ERROR+SHW ;SHOW WHAT?? +1$: JSR PC,GTLP ;GET POINTER TO LINE IN F + JSR PC,PRLN ;PRINT LINE + PRCR +POL2: SEZ +POL3: RTS PC + + + +;PRINT PROC POINTED TO BY B +PSHOW: SAVE B + JSR PC,SHTITL ;CLZ IF IF PROC EXISTS; RETURNS WITH B POINTING TO ARRAY + ;F POINTS TO THE FIRST LINE + BEQ PSHOW1 ;JUST RETURN + MOV @PBASE,B ;GET POINTER TO THE ARRAY + PUSH PROEND(B) ;PUSH RELATIVE POINTER TO THE END OF PROC +PSHLIN: CMP F,(P) ;AT THE END + BEQ PSHDON ;DONE + BHI PSHBUG ;ERROR + JSR PC,PRLN ;PRINT LINE OFFSET TO BY F, AND RETURN OFFSET TO NEXT LINE IN F + PRCR ;CARRIAGE RETURN + BR PSHLIN +PSHDON: TST (P)+ ;POP OFF POINTER TO THE END OF THE FILE + TST WRTFLG ;WRITING A FILE, OR PAPER TAPE + BNE 1$ ;YES, SO ALWAYS PRINT THE END + SUB TOPRNM,(P) + BIT #7777,(P) + BEQ PSHOW2 ;YES, DONT PRINT END +1$: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN +PSHOW2: TST (P)+ + CLZ + RTS PC +PSHOW1: TST (P)+ + SEZ + RTS PC +PSHBUG: .BUG. + +PON: +SHALNA: ;SHOW ALL NAMES + ;USES A-F + JSR PC,GNOLEI +SHALN1: JSR PC,GNOLE ;GET NEXT UOE + BEQ POL2+2 + MOV B,F + MOV #VBIND,A + JSR PC,.BINDL + BEQ SHALN1 ;NO THING FOR THIS UOE + MOV B,C ;SAVE VALUE PTR + MOV F,B ;GET UOE PTR + TST WRTFLG + BEQ SHALN2 ;NO + TST C ;IS VALUE = "UNBOUND"? (0?) + BEQ SHALN1 ;SKIP THIS ATOM + SPUSH B +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + SPOP B + JSR PC,PPNAME ;PRINT THE NAME + PRTXT ^\ (\ + BR SHALN3 +SHALN2: JSR PC,PRUV ;PRINT THE NAME +STLANC +ENGINS +ENDENG +FRINS +ENDLAN +SHALN3: SPACE + SPUSHS C + INC NBKTS + JSR PC,PRS1 + ADD #2,S + TST WRTFLG + BEQ SHALN4 + PRTXT ^\ )\ +SHALN4: PRCR + BR SHALN1 + + +POARR: JSR PC,GNOLEI +POARR1: JSR PC,GNOLE ;GET NEXT UOE +.IFZ + BEQ POARR6 + .IFF + BNE 1$ + JMP POARR6 +1$: +.ENDC + MOV B,F ;PTR TO UOE + MOV #ABIND,A + JSR PC,.BINDL ;GET ARRAY BINDING + BEQ POARR1 ;NO BINDING FOUND + JSR PC,POARR5 ;PRINT ARRAY NAME,SIZE,TYPE + BR POARR1 ;LOOK FOR MORE ARRAYS +POARR5: MOV B,C ;SAVE VALUE PTR + MOV F,B ;GET UOE PTR + JSR PC,PPNAME ;PRINT THE NAME +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + MOV C,B ;SAVE VALUE PTR + PUSH B + JSR PC,ASIZE2 ;PUTS DIMS. OF ARAY IN LIST + MOV C,B ;PPTR TO LIST + JSR PC,PRLST ;PRINT IT + SPACE + PRTXT ^/ TYPE/ + POP B ;VALUE PTR + MOV 4(B),B ;TYPE/DIM WORD IN ARRAY HEADER + BIC #7777,B ;GET THE TYPE + BEQ POARR2 ;TYPE POINTER + CMP #FNUM,B + BEQ POARR3 ;TYPE FNUM +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + BR POARR4 +POARR2: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + BR POARR4 +POARR3: +STLANC +ENGINS +ENDENG +FRINS +ENDLAN +POARR4: PRCR ;CARRIAGE RETURN + SEZ +POARR6: RTS PC +PO1AR: JSR PC,GTUOEB + BEQ 1$ + MOV B,F +1$: MOV #ABIND,A + JSR PC,.BINDL +.IFZ + BNE POARR5 + ERROR+UDA + .IFF + BEQ 2$ + ERROR+UDA +2$: JMP POARR5 +.ENDC + +CONTEN: ;MAKE A LIST OF ALL ATOMS THAT HAVE A PROCEDURE + CLR F + JSR PC,SLISTB + JSR PC,GNOLEI +CONTN1: JSR PC,GNOLE + BEQ CONTN2 ;DONE + JSR PC,BURYQX ;CHECK TO SEE IF IT IS BURRIED + BEQ CONTN1 + MOV B,D + JSR PC,.BINDF ;A PROCEDURE + BEQ CONTN1 ;NOPE + MOV D,C + JSR PC,.LOADC ;GET PNAME + MOV #LSTR,A + JSR PC,LISTB + BR CONTN1 +CONTN2: JSR PC,FLISTB + CLZ + RTS PC + +;INPUT - UOE POINTER IN B +;OUTPUT - PRINTS TITLE LINE, OUTPUTS POINTER TO THE FIRST LINE OF PROC IN F, POINTER +; TO THE PROCEDURE IN B. SEZ IF NO PROCEDURE. +SHTITL: PUSH A + SPUSH B + SPUSH C + JSR PC,.BINDF ;GET POINTER TO THE FUNCTION IN B + BNE 1$ ;GOT THE BINDING + JMP RETC ;JUST RETURN +1$: + MOV (B),PBASE ;MOVE POINTER TO THE BINDING NODE INTO PBASE +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + MOV 2(P),B ;POINT TO THE ATOM AGAIN + JSR PC,PPNAME ;PRINT THE NAME OF THE ATOM + MOV #HEADER,F ;THE INITIAL OFFSET + ADD @PBASE,F ;MAKE IT ABSOLUTE FOR NOW + SPUSH (F)+ ;PUSH NUMBER OF BYTES IN THIS LINE + SUB @PBASE,F ;MAKE F RELATIVE + ADD F,(P) ;MAKE IT POINT TO THE NEXT LINE + ADD #2,F ;SKIP THE NUMBER OF VARIABLES +VARLOP: CMP F,(P) ;DONE? + BEQ VARDON ;YES + SPACE + ADD @PBASE,F ;MAKE POINTER ABSOLUTE + MOV (F)+,B ;GET THE POINTER TO THE VARIABLE + SUB @PBASE,F ;MAKE THE POINTER RELATIVE AGAIN + MOV B,A ;COPY IT + BIC #7777,A ;CLEAR THE POINTER PART + JSR PC,PRTAB ;PRINT THE TOKEN IN A,,B + BR VARLOP ;NEXT!! +VARDON: PRCR ;PRINT CR + SPOP F ;POP POINTER TO THE NEXT LINE + JMP SRETC ;RETURN + +;INPUT - F IS OFFSET TO THE LINE TO PRINT, OUTPUT F OFFSETED TO THE NEXT LINE +PRLN: PUSH A + SPUSH B + SPUSH C + SPUSH D + ADD @PBASE,F ;MAKE F ABSOLUTE + SPUSH (F)+ ;PUSH NUMBER OF BYTES IN THIS LINE + ADD F,(P) ;MAKE IT A POINTER TO THE NEXT LINE + SUB @PBASE,(P) ;MAKE THE POINTER RELATIVE + INC NBKTS ;PRINT THE OUTER LIST BRACKETS + BIC #DPQF,FLAGS2 ;ALLOW PRINTING OF QUOTES + MOV (F)+,B ;THE LINE NUMBER + SUB @PBASE,F ;MAKE F RELATIVE AGAIN + MOV #SNUM,A ;PUT THE TYPE INTO A + JSR PC,PRTAB ;PRINT THE TOKEN IN A,,B +PRLN1: CMP F,(P) ;DONE? + BEQ PRLN2 ;YES + SPACE ;TYPE A SPACE + ADD @PBASE,F ;MAKE F ABSOLUTE + MOV (F)+,B ;GET THE NEXT TOKEN + SUB @PBASE,F ;MAKE IT RELATIVE AGAIN + MOV B,A ;COPY IT FOR THE TYPE + BIC #7777,A ;DELETE THE POINTER PART + JSR PC,PRTAB ;PRINT THE TOKEN IN B + BR PRLN1 ;NEXT TOKEN +PRLN2: DEC NBKTS ;FIX IT FOR THE NEXT CALL + SPOP F ;WELL RESTORE F + JMP RETD ;AND RETURN + +.GLOBL BUG ;133 +;LISTIFY THE PROCEDURE SPECIFIED + +TEXTT: JSR PC,GUOEB ;GET POINTER TO THE ATOM + BNE 1$ ;OKAY +2$: ERROR+HNM ;WHAT DID YOU ASK TO TEXTIFY? +1$: JSR PC,.BINDF ;GET THE PROCEDURE BINDING + BEQ 2$ ;OUGHT TO HAVE A PROCEDURE BINDING + PUSH PROEND(B) ;PUSH THE FINISHING ADDRESS + MOV (B),PBASE ;SET UP POINTER TO THE PROCEDURE + MOV #HEADER,C ;THE INITIAL OFFSET + CLR F ;THIS IS USED BY LISTB + JSR PC,LSTIT ;LIST THE TITLE, OUTPUT IN TOPS, AND RETURNS A,,B + BR TEXTL1 ;PUT IN ON THE LIST + +TEXTLP: JSR PC,LSTLIN ;LISTIFY'S LINE, AND PUSHES RETURNS IT IN A,,B + ;GC-PROTECTED BY TOPS + MOV #LIST,A ;SAY THIS IS A LIST +TEXTL1: JSR PC,LISTB ;AND BUILD ME A LIST + CLR TOPS ;CLEAR THE GC-PROTECTION + CMP C,(P) ;ARE WE AT THE END OF THE PROC YET? + BLO TEXTLP ;NOT YET, GET NEXT LINE + BHI TEXTBG ;PAST IT, BUGGGGGG + TST (P)+ ;POP OFF END OF PROC MARKER + CLZ ;DONE + RTS PC +TEXTBG: ERROR+BUG + +;TAKES OFFSET TO LINE IN C, LISTIFY'S IT, AND RETURNS IT IN A,,B, AND IN TOPS +LSTLIN: + MOV C,D ;COPY OFFSET TO TITLE LINE + ADD @PBASE,D ;MAKE IT ABSOLUTE + PUSH 2(D) ;SAVE THE LINE NUMBER + JSR PC,LTOK ;LISTIFY THE LINE + SPOP B ;GET THE LINE NUMBER + SPUSH C ;SAVE POINTER TO NEXT LINE + JSR PC,.CSNLS ;CONVERT IT TO AN LSTR + MOV B,TOPS ;GC-PROTECT THE NUMBER + MOV @S,A ;POINTER TO THE LINE + BIC #170000,A ;CLEAR THE TYPE + BIS #LSTR,A ;SAY THIS IS AN LSTR + JSR PC,GRBAD ;GET A NODE THAT POINTS TO THE NUMBER, AND THE LINE + BIS #LIST,C ;THIS IS THE POINTER TO THE LINE + MOV C,B ;COPY IT + MOV B,TOPS ;SAVE IT TO GC-PROTECT IT + MOV #LIST,A ;MAKE IT LIST TYPE + SPOP C ;AND GET BACK POINTER TO THE NEXT LINE + ADD #2,S ;POP OFF THIS LIST (IT ISN'T NEEDED) + RTS PC + + +.GLOBL $TOTO ;134 +;TAKES POINTER TO THE PROCEDURE ARRAY IN PBASE AND B, AND OFFSET TO THE TITLE LINE IN C +;RETURNS C OFFSETED TO THE FIRST REAL LINE OF PROCEDURE +LSTIT: + ADD B,C ;MAKE C ABSOLUTE + MOV PROATM(B),B ;GET POINTER TO THE PROCEDURE ATOM + JSR PC,.LOAD ;AND GET POINTER TO THE PNAME + SPUSH B ;AND PUSH IT + SUB @PBASE,C ;MAKE C RELATIVE AGAIN + JSR PC,LTOK ;GET THE VARIABLES LISTIFIED, AND OUTPUT ON S PDL + SPUSH C ;SAVE POINTER TO THE NEXT LINE + MOV #LSTR,A ;MAKE THE LSTR POINT TO "TO" +STLANC +ENGINS +ENDENG +FRINS ;GET POINTER TO "TO" +ENDLAN + JSR PC,GRBAD ;C POINTS TO NODE WITH "TO" IN IT + MOV C,TOPS ;THIS WILL BE POINTER TO THE LINE + MOV @S,A ;GET POINTER TO THE LIST OF VARIABLES + BIC #170000,A ;CLEAR OUT THE TYPE + BIS #LSTR,A ;THE PNAME IS AN LSTR + MOV 2(P),B ;THE POINTER TO THE PNAME OF THE ATOM + JSR PC,GRBAD1 ;MAKE THE "TO" NODE POINT TO A NODE CONTAINING A,,B + ADD #2,S ;POP OFF LINE WITH VARIABLES IN IT + MOV #LIST,A ;LIST TYPE + BIS A,TOPS ;SET IN THE TYPE + MOV TOPS,B ;GET BACK POINTER TO THE "TO" NODE + SPOP C ;GET POINTER TO NEXT LINE + TST (P)+ + RTS PC + +;ACCEPTS POINTER TO TOKEN STRING IN C, INCREMENTS C AND LISTIFIES WHAT IT POINTS TO +;PUSHES LIST ON S PDL +LTOK: + ADD @PBASE,C ;MAKE C ABSOLUTE + MOV (C)+,D ;GET THE COUNT + TST (C)+ ;SKIP THE "LINE NUMBER" + SUB @PBASE,C ;MAKE IT REALIVE AGAIN +LTOK1: SPUSH C ;SAVE POINTER + JSR PC,SLISTB ;START LIST BUILDING + ASR D ;INTO WORD COUNT + DEC D ;AND DECREMENT IT + BEQ LTOKDN +LTOKLP: SPOP C ;GET POINTER TO LINE + ADD @PBASE,C ;MAKE C ABSOLUTE + MOV (C)+,B ;GET THE NEXT TOKEN + SUB @PBASE,C ;MAKE IT RELATIVE AGAIN + SPUSH C ;AND PUT IT BACK ON + MOV B,A ;COPY FOR THE TYPE + BIC #7777,A ;CLEAR IT OUT + CMP A,#UFUN ;IS IT A SYSFUN, OR INFIX OPERATOR? + BLO LTOKSY ;SYSTEM FUNCTION + BEQ LTOKUF ;USER FUNCTION + MOV #':,C ;FOR USER VARIABLE + CMP #UVAR,A ;USER VARIABLE? + BEQ LTOKAD ;ADD CHARACTER IN D TO ATOM IN B + MOV #'",C ;ATOM PRINT " + CMP #ATOM,A ;ATOM? + BEQ LTOKAD ;ADD CHARACTER IN D TO ATOM IN B + CMP #LSTR,A ;IS IT ALREADY AN LSTR? + BNE LTOKLT ;NO, MUST BE INUM,FNUM, OR LIST, OKAY AS IS + JSR PC,CHRLST ;ADD " TO THE LSTR +LTOKL1: MOV TOPS,B ;POINTER TO THE NEW LSTR +LTOKL2: MOV #LSTR,A ;IT IS AN LSTR +LTOKLT: JSR PC,LISTB ;BUILD A LIST ELEMENT FROM A,,B + SOB D,LTOKLP ;GO BACK FOR MORE +LTOKDN: JSR PC,FLISTB ;FINISH LIST, AND PUT POINTER TO IT IN B + SPOP C ;RESTORE LINE POINTER + JMP CLRTOP + +LTOKSY: JSR PC,LSFUN ;CONVERT THE FUNCTION TO LSTR POINTED TO BY TOPS + BR LTOKL1 ;ADD IT TO THE LIST +LTOKUF: JSR PC,.LOAD ;POINTER TO THE PNAME IN B, TYPE IN A + BR LTOKL2 ;ADD IT TO THE LIST +LTOKAD: JSR PC,CHRATM ;ADD CHARACTER TO PNAME + BR LTOKL1 ;ADD IT TO THE LIST + +;APPEND CHARACTER IN C TO BEGINNING OF PNAME OF ATOM POINTED TO BY B +CHRATM: JSR PC,.LOAD ;GET THE POINTER TO PNAME IN B +;DROP INTO CHRLST + +;APPEND CHARACTER IN D TO BEGINNING OF PNAME IN B, OUTPUT POINTER IN TOPS +;OUTPUT IS PROTECTED BY TOPS +CHRLST: MOV B,A ;POINTER TO THE REST OF THE PNAME + MOV C,B ;GET THE CHARACTER TO ADD + BIC #170000,A ;CLEAR OUT THE OLD TYPE + BIS #SSTR,A ;AND MAKE IT AN SSTR + JSR PC,GRBAD ;GET A NODE CONTAINING PNAME AND THE SINGLE CHARACTER + BIS #LSTR,C ;SAY IT IS AN LSTR + MOV C,TOPS ;GC-PROTECT IT + RTS PC + +;CONVERT SFUN IN B TO AN LSTR, OUTPUT IN TOPS +LSFUN: SPUSH D ;SAVE THE NUMBER OF TOKENS + SPUSH PCHR ;SAVE THE PCHR + JSR PC,BLSTI ;INIT THE LIST BUILD + MOV #BLST,PCHR ;ROUTINE FOR ADDING CHARACTERS TO THE LSTR + MOV B,A ;COPY POINTER FOR PROAB + JSR PC,PROAB ;PRINT THE NAME OF THE FUNCTION + JSR PC,BLSTF ;FINISH THE LSTR + POP PCHR ;PUT BACK PRINT ROUTINE + SPOP D ;GET BACK NUMBER OF TOKENS + RTS PC + +CVSFLS: JSR F,CACSAV ;SAVE AC'S + JSR PC,LSFUN ;AND CONVERT IT + JSR F,CACRES ;RESTORE AC'S + RTS PC + .SBTTL ILINE & ERSET STUFF +.GLOBL CURPNT,ERRPNT,LASTER,NLINEL,NPROCL,NTOKEL ;137 +ILINE: + MOV #CURPNT,PBASE ;FAKE A BINDING NODE FOR THE CURRENT LINE + MOV #HEADER,C + CLR F + JSR PC,LTOK ;LISTIFY IT + CLZ ;AND RETURN IT + RTS PC + +ERRPRO: ;OUTPUT NAME OF PROC EXTENT AT LAST ERROR + MOV NPROCL,B + BEQ ERRPR1 + JSR PC,.LOAD + PUSHS B + CLZ + RTS PC + +ERRPR1: PUSHS #LSTR + RTS PC +ERRLIN: ;OUTPUT LINE # EXTENT AT LAST ERROR + MOV NLINEL,B + BR NTOKE1 +ERRTOK: ;OUTPUT TOKEN # EXTENT AT LAST ERROR + MOV NTOKEL,B +NTOKE1: JMP R1NARG +ERRLOC: ;OUTPUT ADDR OF LAST ERROR + MOV LASTER,B + BR NTOKE1 +ERRNUM: ;OUTPUT NO. OF LAST ERROR + MOV ERRPNT,B + CMP (B)+,(B)+ + JSR PC,GETERW + BR NTOKE1 +ERRNAM: MOV #4,C ;MAX CHARS + MOV ERRPNT,ERRPT + JSR PC,BLSTI ;START AN LSTR +ERRNA2: JSR PC,GETERB + INC ERRPT + TST D + BEQ ERRNA1 + JSR PC,BLST + SOB C,ERRNA2 ;CONTINUE UNLESS DONE +ERRNA1: JSR PC,BLSTF + BEQ ERRPR1 + PUSHS TOPS + CLZ + RTS PC + +.GLOBL BRAKEL ;138 +.GLOBL ERSDIS ;139 +.GLOBL PBE ;140 +ERRBRE: ;OUTPUT BRAKE(U) + MOV BRAKEL,B + BR NTOKE1 +ERRSET: JSR PC,GTUOEB + BEQ 1$ + ERROR+HNM +1$: MOV B,ERPROC + SEZ + RTS PC +ERRCLE: CLR ERPROC +ERRC3: RTS PC +ERNAME: ;ERASE NAME + JSR PC,GTUOEB + BEQ ERN2 + CMP #UFUN,A ;AN SFUN OR INFIX? + BGT 1$ + ERROR+ERW +1$: JSR PC,CVSFLS + MOV #ATOM,A + JSR PC,.OBSCH + BEQ ERRC3 +ERN2: MOV #VBIND,A + JSR PC,.UNBND + SEZ + RTS PC + .SBTTL ERASE +ERASE: JSR PC,GTUOEB ;GET THE PROCEDURE TO ERASE + BNE ERASE1 ;NOT A UOE, MUST BE A SYSTEM WORD + JSR PC,ERPR ;ERASE THAT PROCEDURE + BEQ 1$ +2$: SEZ + RTS PC +1$: TST REDFLG ;IF READING FROM FILE + BNE 2$ ;IGNORE ERASE ERRORS +ERASER: ERROR+PNH ;CAN'T FIND THE STUPID THING +ERASE1: MOV #ERSDIS,A ;POINT TO THE ERASE DISPATCH TABLE +ERASE2: CMP (A)+,B ;IS IT THIS WORD? + BNE 1$ ;NO, SKIP THE ADDRESS + JMP @(A) ;GO DO THAT +1$: TST (A)+ ;PASS THE ADDRESS + TST (A) ;AT THE END OF THE TABLE? + BNE ERASE2 ;NO +ERASE3: ERROR+ERW ;ERASE WHAT? + +ERALL: JSR PC,ERALPR ;ERASE ALL THE PROCEDURES + JSR PC,ERALNA ;ERASE ALL THE NAMES + JSR PC,ERARAS ;ERASE ALL THE ARRAYS + JMP TOPLEVEL ;RTS PC FOR NEW SYSTEM + +;ERASE LINE +ERL: +ERLINE: TST TOPRNM ;EDITING A PROCEDURE? + BNE 1$ ;YES + ERROR+OIP +1$: JSR PC,GTLN ;GET LINE NUMBER IN B + BEQ ERASE3 ;LOSE LOSE + NEG B ;TO DELETE THIS LINE + JSR PC,ADLN ;DO THE DEED +ERLI1: SEZ + RTS PC + +;ERASE PROCEDURE POINTED TO BY THE ATOM IN B +ERPR: BIC #170000,B ;CLEAR OUT THE TYPE + BIS #UFUN,B ;MAKE IT INTO A UFUN + CMP B,TOPRNM ;IS IT THE PROCEDURE BEING EDITED? + BNE ERPR2 ;NO, ALLOW IT TO HAPPEN +ERPR1: ERROR+PBE ;PROCEDURE BEING EDITED +ERPR2: JSR PC,.BINDF ;GET THE BINDING + BEQ ERLI1 ;CAN'T FIND IT, FORGET IT +DELPRO: TST PROSTK(B) ;IS IT REFERENCED ON THE STACK? + BEQ DELIT ;NO, JUST DELETE IT + MOV #-PROCAR,PROTYP(B) ;CHANGE TYPE TO DELETED + MOV (B),C ;POINTER TO THE 2ND WORD OF BINDING NODE + BIC #170000,-(C) ;CLEAR OUT THE TYPE OF THE FIRST WORD + BIS #DBIND,(C) ;SET IN DELETED PROCEDURE BINDING + RTS PC ;AND RETURN +DELIT: SPUSH B ;SAVE B + TST PROTYP(B) ;WAS IT DELETED PREVIOUSLY? + BMI DELHRD ;DELETE IT THE HARD WAY + MOV PROATM(B),B ;GET POINTER TO THE BINDING NODES + MOV #FBIND,A ;DELETE THE FUNCTION BINDING + JSR PC,.UNBND ;DELETE THE BINDING +DELARR: SPOP B ;GET BACK POINTER TO THE ARRAY + JSR PC,.RELES ;RELEASE IT + CLZ + RTS PC + +DELHRD: MOV PROATM(B),B ;GET POINTER TO THE BINDING NODES + MOV B,C ;THIS IS THE POINTER TO THE PREVIOUS NODE + MOV B,A ;AND SET UP POINTER TO THE START ALSO +DELOP: MOV C,D ;GET POINTER TO THE PREVIOUS + MOV A,C ;THE NEXT NODE TO LOAD + JSR PC,.LOADC ;LOAD IT UP + CMP B,(P) ;IS IT POINTER TO THE SAME ADDRESS? + BNE DELOP ;NO, TRY TRY AGAIN + MOV A,B ;WHAT THE NODE POINTS TO + BIC #7777,A ;IS IT A DBINDED NODE? + CMP A,#DBIND ;WELL? + BEQ 1$ ;YES, ALL IS WELL + MOV B,A ;RESTORE A + BR DELOP ;AND TRY AGAIN +1$: MOV D,C ;POINTER TO THE NODE BEFORE THIS + JSR PC,.LDP1 ;GET WHAT IT POINTS TO + BIC #7777,A ;GET THE TYPE TO PUT ON THE NEW POINTER + BIC #170000,B ;CLEAR OUT THE POINTER + BIS B,A ;SET IN THE POINTER INTO THE TYPE + JSR PC,.STP1 ;AND CLOBBER THAT NODE TO POINT TO THE NEXT + BR DELARR ;NOW DELETE THE ARRAY + +;ERASE ALL PROCEDURES +ERALPR: TST TOPRNM ;ANY BEING EDITED? + BEQ ERALP1 ;NO, CONTINUE + MOV TOPRNM,B ;GET UOE EDITED INTO B + BR ERPR1 ;TO REPORT THE ERROR +ERALP1: JSR PC,GNOLEI ;INITIALIZE THE GET NEXT OBLIST ROUTINE +ERALP2: MOV #FBIND,A ;THE BINDING TO LOOK FOR + JSR PC,GNOLE ;GET THE NEXT OBLIST ELEMENT + BEQ ERLI1 ;RETURN WHEN WE CANT GET ANY MORE + JSR PC,BURYQ ;IS IT BURIED? + ;ALSO GETS INDEX TO ARRAY IN B + BEQ ERALP2 ;YES, OR ISN'T A PROCEDURE + JSR PC,DELPRO ;DELETE THE PROCEDURE, IF AT LEVEL 0, OR FIX + ;IT TO BE DELETED LATER + BR ERALP2 ;FOR ALL THE PROCEDURES + +.GLOBL $ALL,$TOUT,.DELET,.DELI,TF6 ;141 +;ERASE ALL NAMES +ERALNA: JSR PC,GNOLEI ;INIT GET NEXT OBLIST ELEMENT +ERALN1: JSR PC,GNOLE ;GET THE NEXT OBLIST ELEMENT + BEQ ERALN2 ;DONE + MOV #VBIND,A ;DELETE VARIABLE BINDINGS + JSR PC,.UNBND + BR ERALN1 ;DELETE THEM ALL +ERALN2: RTS PC + + +BURY: MOV PC,TF6 ;SET THE FLAG SAYING WE ARE ENABLING THIS FEATURE + BR BURY1 ;GO DO IT +EBURY: CLR TF6 ;CLEAR A FLAG FOR LATER +BURY1: MOV #TPBF,D ;THE FLAG TO CHANGE + BR TRACE2 ;DO IT + +STEP: MOV PC,TF6 ;SAY WE ARE TURNING ON STEP + BR STEP1 +ESTEP: CLR TF6 +STEP1: MOV #TPSF,D ;THE FLAG FOR STEPPING + BR TRACE2 + +TRACE: MOV PC,TF6 + BR TRACE1 +ETRACE: CLR TF6 ;CLEAR THE TRACE +TRACE1: MOV #TPTF,D ;THE TRACE FLAG +TRACE2: JSR PC,GTUOEB ;GET THE OBLIST ELEMENT INTO B + BNE TRCSYS ;WASN'T USERS PROC, GET A SYSTEM WORD + JSR PC,CSSTF ;SET THE CORRECT FLAG FOR PROC IN B + BNE TRCDON ;DONE WITH THIS +TRAERR: ERROR+PNH ;NO PROCEDURE TO DO THIS WITH +TRCSYS: CMP #SFUN,A ;IS IT A SYSTEM FUNCTION + BNE TRAERR ;NOPE +.IFNZ ENG + CMP #$ALL,B ;IS IT TRACE ALL? + BEQ TRCALL ;YES +.ENDC +.IFNZ FR + CMP #$TOUT,B ;IS IT TRACE TOUT? + BEQ TRCALL ;YES +.ENDC + ERROR+ERW ;TRACE WHAT????? +TRCALL: JSR PC,GNOLEI ;INIT GET NEXT USER OBLIST ELEMENT +TRCAL1: JSR PC,GNOLE ;GET THE NEXT ELEMENT + BEQ TRCDON ;FINISHED + CMP #TPBF,D ;IS IT AN ERASE BURY? + BEQ TRCAL3 ;YES, DO IT REGARDLESS, ELSE IF PROC'S ARE BURRIED, DONT + ;TOUCH THEM + JSR PC,BURYQ ;IS IT BURIED? + BEQ TRCAL1 ;YES, DONT TOUCH THEM +TRCAL2: JSR PC,CSSTF1 ;SET OR CLEAR THE APPROPRIATE FLAG + BR TRCAL1 ;NEXT!! +TRCAL3: JSR PC,CSSTF ;CLEAR THE BURY FLAG + BR TRCAL1 +TRCDON: SEZ + RTS PC + +;THIS ENTRY SETS OR CLEARS A FLAG IN D, ACCORDING TO TF6, PROC POINTED TO BY UOE IN B +;CSSTF1 DOES THE SAME, EXCEPT WITH POINTER TO PROC IN B +CSSTF: JSR PC,.BINDF ;GET THE FUNCTION BINDING IN B + BEQ TRCDON ;FAILED MISERABLY +CSSTF1: MOV B,A ;GET POINER TO ARRAY INTO A + ADD #HEADER+2,A ;POINT TO THE FLAGS FOR THIS PROC + BIC D,(A) ;CLEAR THE FLAG + TST TF6 + BEQ 1$ ;NO, FINE + BIS D,(A) ;WELL SET IT AFTER ALL +1$: CLZ + RTS PC + +;THIS RETURNS WITH Z SET IF THE PROCEDURE IS BURRIED, B GETS CLOBBERED TO POINT TO THE +;ARRAY'S ADDRESS +BURYQ: PUSH A + SPUSH B + SPUSH C + JSR PC,.BINDF ;GET THE BINDING IF IT EXISTS + BEQ BURYQ1 ;NO PROCEDURE + MOV B,2(P) ;RETURN THIS POINTER +BURYQ3: BIT #TPBF,HEADER+2(B) ;IS THE BURY BIT ON? + BEQ BURYQ2 ;NO, RETURN WITH Z CLEARED +BURYQ1: JMP RETC +BURYQ2: JMP SRETC + +BURYQX: PUSH A + SPUSH B + SPUSH C + JSR PC,.BINDF ;GET THE BINDING + BEQ BURYQ1 ;NO PROCEDURE + BR BURYQ3 ;OTHERWISE DO A PROBLEM + +.IF NZ DEBUGR +STRACS: BIT #TRACEF,FLAGS2 + BEQ STRA2 + SPACE + BR STRA1 +STRACE: BIT #TRACEF,FLAGS2 ;SYSTEM TRACE + BEQ STRA2 +STRA1: INC NBKTS + PUSH A + PRTXT ^/CT=/ + BIC #DPQF,FLAGS2 + JSR PC,PRCT + PRTXT ^/ CO=/ + JSR PC,PRCO + PRTXT ^/ S=/ + BIC #DPQF,FLAGS2 + JSR PC,PRS1 + PRCR + CLR NBKTS + POP A +STRA2: RTS PC + +SETSTF: BIS #TRACEF,FLAGS2 ;SET SYSTEM TRACE FLAG + BR SEZRTS + +CLRSTF: BIC #TRACEF,FLAGS2 + BR SEZRTS +.ENDC +FLEV: MOV FUNLEV,B ;RETURN USER PROC CALL DEPTH +FLEV1: JMP R1NARG +NODES: ;OUTPUT NO. OF NODES IN FREE STG LIST + MOV NNIFSL,B + BR FLEV1 + .SBTTL UTILITY ROUTINES +.GLOBL ALEVN,CTYO1,LVERNF,RNSEED ;144 +.GLOBL DEBSW,SECRET,SETTTY,TINECH ;145 +.GLOBL .CLOS0,DELTMP,ERRORN,ERTAB,FBUG,RESTTY,SETCH0 ;146 +.GLOBL ERRPT,NOADDR,ROTTAB ;147 +.GLOBL ERCLR1,ERCLR2 ;148 +.GLOBL BRKMOF,DSKERW,ENGDER,MUCWRD,NAME ;149 +.GLOBL PPOPL,PPUSHL,SPOPL ;150 +.GLOBL PDLEMR,POPLM,PPDLCP,PPEMR,PPLIMT,PSWPAD ;151 +.GLOBL SPEMR,SPLIMT,SPOPLM,SSWPAD ;152 +.GLOBL SPDLCP ;153 +.GLOBL INLEN ;161 +.GLOBL LNTB ;162 +.GLOBL OOT ;163 +.GLOBL BMT,GCBITS ;164 +.GLOBL LMT,MKDC,SPMSWP ;165 +.GLOBL GCMKL,PALETT,PALMAX ;168 +.GLOBL DFLAGS,DSGCF ;169 +.GLOBL LUNN,NNGC,NODTOP ;170 +.GLOBL EXNODE ;171 + +VERSN: MOV LVERNF,B + BR RANDO1 +RANDOM: + MOV RNSEED,B ;GET OLD SEED + MUL #71275,B ;MUL SEED BY GOOD NUMBER!! + ADD #13713,B ;ADD ANOTHER GOOD NUMBER!! TO LOW ORDER PART + MOV B,RNSEED ;THIS IS THE NEW SEED + MOV B,A + MUL #10.,A ;MULTIPLY IT BY 10 + MOV A,B ;HIGH-ORDER PART IS THE DESIRED DIGIT + ADD #5,B +RANDO1: JMP R1NARG +BELL: MOV #7,B + JMP CTYO1 + + +DEBUG: TST ALEVN + BEQ DEBUG1 + PRTXTC ^\OFF\ + CLR ALEVN + JMP TOPLEVEL +DEBUG1: PRTXTC ^\ON\ + MOV #1,ALEVN + BR SEZRTS +SGCF: JSR PC,CKSST + BIS #MGCF,FLAGS2 +SEZRTS: SEZ + RTS PC +CGCF: JSR PC,CKSST + BIC #MGCF,FLAGS2 + BR SEZRTS + +STATUS: BIT #SSF,FLAGS2 + BNE STATU2 ;IF ON TURN OFF + JSR PC,TINECH + JSR PC,RDSTR ;READ A STRING + BEQ STATU2 ;EMPTY OR BREAK + MOV @S,B ;SEE IF EQUAL TO "SECRET + MOV #SECRET,C + JSR PC,EQ.TXT + BEQ STATU1 ;NOPE + BIS #SSF,FLAGS2 ;YES + POPS A ;POINTER TO STRING READ IN + PRTXTC ^\ON\ + BR STATU3 +STATU1: POPS A +STATU2: PRTXTC ^\OFF\ + BIC #SSF,FLAGS2 +STATU3: JMP SETTTY + +CKSST: TST DEBSW + BNE CKSST1 + BIT #SSF,FLAGS2 + BEQ CKSST9 +CKSST1: RTS PC +CKSST9: ERROR+HNM + +SPNF: BIS #PNNLF,FLAGS2 + BR SEZRTS +CPNF: BIC #PNNLF,FLAGS2 ;CLEAR IT + BR SEZRTS + +COMT: .BUG. ;GNT SHOULD SWALLOW ALL COMMENTS; + .SBTTL ERRORS AND HANDLER +EMTBRK: MOV #SRET,(P) ;PRETEND TO FAKE SOMETHING OUT + RTT +ERRBRK: +ERRBK: LDFPS #40300 + JSR F,CACSAV ;SAVE THE AC'S + TST REDFLG ;READING? + BEQ ERRBK1 ;NO +.IF NZ FILDSK + JSR PC,SETCH0 + JSR PC,.CLOS0 ;GO CLOSE INPUT FILE +.ENDC + TST TOPRNM ;STILL DEFINING A PROCEDURE? + BEQ ERRBK1 ;NOPE + JSR PC,END ;WELL, FINISH IT UP +ERRBK1: CLR GCPREV ;DELETE PENDING WORD AND SENTENCE COMMANDS +.IIF NZ FILDSK, JSR PC,DELTMP ;DELETE THE CAPABILITY TO THE FILE + TST TOPRNM ;DEFINING PROC? + BEQ 1$ ;NO + MOV #'>,PRMTCH ;PROMPT WITH ">" + BR 2$ +1$: MOV #'?,PRMTCH ;PROMPT WITH A "?" +2$: JSR PC,RESTTY ;RESTORE THE TTY STATUS + MOV #TYI,GCHR ;GET CHARACTERS FROM THE TTY NOW + MOV #TYO,PCHR ;AND PRINT TO THE TTY + MOV 6*2(P),A ;GET THE TRAP ADDRESS + MOV A,LASTER ;AND SAVE IT + SUB #2,A ;POINT TO THE TRAPPING CALL + JSR PC,GETAML ;GET IN A MEMORY LOCATION POINTED TO BY A + BIC #177600,A ;GET THE TRAP CODE + MOV A,ERRORN ;SAVE THE ERROR NUMBER + ASL A ;TURN IT INTO AN INDEX + MOV ERTAB(A),ERRPNT ;GET THE POINTER TO THE ERROR MESSAGE + CLR NLINEL ;NO ERROR LINE YET + CLR NPROCL ;CLEAR THE PROCEDURE ALSO + MOV BRAKE,BRAKEL ;SAVE THE STATE OF THE BREAK FLAG + TST FUNLEV ;IN A PROCEDURE? + BEQ 3$ ;NOPE + MOV CPP,NPROCL ;THE ERROR PROCEDURE + MOV CPLN,NLINEL ;SAVE THE LINE ERROR CAME FROM +3$: TST ERPROC ;ERROR SET? + BEQ ERRNOT ;NOPE + CMP A,#BUG*2 ;IS IT BUG? + BEQ ERRNOT ;YES, DONT ALLOW ERRSET + CMP A,#FBUG*2 ;SAME WITH FBUG? + BEQ ERRNOT +;FALLS THROUGH TO NEXT PAGE + ;FALLS IN HERE + SPUSH BRAKE ;SAVE THIS + CLR BRAKE ;ERROR PROCEDURES DONT RUN UNDER THE SHADOW OF BRAKE + JSR PC,SAVEVL ;SAVE THE STATE OF THE WORLD + PUSH #0 ;MAKE IT LOOK LIKE A PROCEDURE CALL + JSR PC,SAVPPS ;AND SAVE THE PDLS + BIS #1,CPDLP ;SAY PROCEDURE PUSH + BIS #1,CSPDLP ;SAY AND ERRORSET PUSH (NOT NEEDED I THINK) + BIC #DORF,FLAGS ;NOT A DO OR READ FRAME + BIS #ERRF,FLAGS ;SAY WE HAVE AN ERROR!!!! + MOV ERPROC,CO ;MAKE IT THE CURRENT PROCEDURE + CLR ERPROC ;DONT ALLOW THIS TO BE ERRSET YET + JSR PC,PEVAL ;EVALUTATE THE PROCEDURE + BEQ ERRNT1 ;NO OUTPUT, JUST DO WHAT WE WERE GOING TO + JSR PC,PRS1 ;PRINT THE OUTPUT + JSR PC,RESPPS ;RESTORE PDLS + TST (P)+ ;POP NUMBER OF ARGS + JSR PC,RESEVL ;AND RESTORE EVAL + MOV B,FLAGS ;PUT BACK THE FLAGS + BR DEBUGL ;POP OFF EVERYTHING, AND RETURN +ERRNT1: JSR PC,RESPPS ;RESTORE THE PDLS + TST (P)+ ;POP OFF NUMBER OF ARGS + JSR PC,RESEVL ;AND GET BACK EVAL... + MOV B,FLAGS ;RESTORE THE FLAGS + SPOP BRAKE ;GET BACK BRAKE +ERRNOT: TST NOADDR ;ANY PRINT OCTAL ADDRESS? + BNE ERNOT1 ;NO + MOV LASTER,A ;GET THE ERROR ADDRESS + JSR PC,PRONL ;AND PRINT IT + SPACE ;WITH A SPACE +ERNOT1: JSR F,CACRES ;RESTORE THE AC'S + MOV ERRPNT,ERRPT ;GET THE ERROR MESSAGE POINTER +.IFZ NOERTX + ADD #6,ERRPT ;POINT TO THE START OF THE ERROR MESSAGE +.IFNZ ENG&FR + BIT #FRFLG,LANG ;IN FRENCH? + BEQ ERPRLP ;NO + INC ERRPT ;LOOK BACKWARDS FOR THE FIRST ZERO BYTE +1$: JSR PC,GETERB ;GET ERROR BYTE IN D + TSTB D + BNE 1$ + INC ERRPT ;WE HAVE BACKED UP OVER THE FRENCH ERROR, NOW PRINT IT +.ENDC +ERPRLP: JSR PC,GETERB ;GET THE NEXT BYTE OF ERROR MESSAGE + INC ERRPT ;POINT TO THE NEXT BYTE + TST D + BEQ DEBUGL ;DONE PRINTING, DO THE RIGHT THING NOW + BLT ERPRL1 ;IS A CONTROL BYTE FOR A ROUTINE TO RUN + JSR PC,TYO ;OUTPUT THE CHARACTER + BR ERPRLP ;AND LOOP BACK +ERPRL1: BIC #177600,D ;IT IS THE WORD OFFSET INTO A TABLE, CLEAR THE SIGN EXTEND + ASL D ;INTO A WORD OFFSET + MOV ROTTAB(D),A ;THE ROUTINE TABLE + INC NBKTS ;PRINT BRACKETS + JSR PC,(A) ;CALL THE ROUTINE + BR ERPRLP ;AND ADVANCE THE POINTER +.IFF + MOV #4,A +1$: JSR PC,GETERB + BEQ 2$ + JSR PC,TYO + INC ERRPT + SOB A,1$ +2$: CMP ERRORN,#BRK ;IS IT BREAK? + BNE DEBUGL ;NO, IGNORE IT + JMP BRK.R ;PRINT BREAK OR PAUSE +.ENDC + +PPLACE: MOV FUNLEV,A ;GET THE LEVEL DEEP + BEQ PPLAC1 ;DONT PRINT IT AT TOP LEVEL +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + JSR PC,PRDN ;PRINT THE LEVEL +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + MOV CPLN,A ;GET THE CURRENT LINE NUMBER + JSR PC,PRDN ;AND PRINT IT +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + MOV CPP,B ;THE CURRENT PROCEDURE NAME + JSR PC,PPNAME ;AND PRINT IT +PPLAC1: JMP .CRLF ;AND PRINT CR-LF + +DEBUGL: JSR PC,PPLACE ;PRINT THE PLACE + CLR BRAKE ;NO BREAK + TST ALEVN ;SHOULD WE REALLY ENTER A BREAK LOOP? + BEQ TOPLEVEL ;NOPE, POP AWAY JOE!! +DBUGL1: TST FUNLEV ;TOP LEVEL? + BEQ TOPLEVEL ;YES, JUST FORGET IT + JSR PC,SAVEVL ;SAVE EVAL (AGAIN) + PUSH #0 ;OH WELL, PUSH NUMBER OF ARGS + JSR PC,SAVPPS ;SAVE THE PDLS AGAIN + BIS #1,CPDLP ;SAY THIS IS A PROCEDURE PUSH + BIC #DORF,FLAGS ;NOT DO OR READ FRAME + BIS #ERRF!BRKF,FLAGS ;SAY ERROR, AND BREAK LOOP + JMP MLOOP ;OH WELL, GIVE HIM THE TTY!!! + +TOPLEVEL: + TST FUNLEV ;IN A PROCEDURE? + BEQ 1$ ;NO, JUST CLEAN UP OTHER RANDOM FRAMES + MOV #TOPLEVEL,PSTOPR ;KEEP GOING TO TOPLEVEL + JMP PSTOP1 ;AND STOP THIS PROCEDURE +1$: BIT #DORF,FLAGS ;IN A DO OR READ FRAME? + BEQ ERTL3 ;NO, MUST BE AT TOP LEVEL NOW + MOV #1$,DOFRET ;THE PLACE TO RETURN TO + JMP POPVAR ;AND POP THIS FRAME +ERTL3: CLR A ;CLEAR OUT THE PDLS + JSR PC,PPTA ;POP THE P TO THE BASE OF THE STACK + CLR A + JSR PC,PSTA ;POP THE S PDL TO THE BASE OF THE STACK + CLR CSPDLP ;NO PDL OFFSETS + CLR CPDLP + MOV #ERCLR1,A ;THE START OF THE AREA TO CLEAR + MOV #/2,B ;THE LENGTH IN WORDS OF THE AREA TO CLEAR +3$: CLR (A)+ ;CLEAR IT OUT + SOB B,3$ + BIC #ERRF+BRKF,FLAGS ;CLEAR ALL SORTS OF RANDOM FLAGS + JMP MLOOP ;AND GO TO TOP LEVEL + +FBUGB: BPT ;BREAK ON A FATAL BUG + JMP TOPLEVEL ;TRY TO RECOVER + +BRK.R: MOV BRAKE,A ;THE BREAK FLAG + CLR BRAKE ;CLEAR IT + SPUSH MUCWRD ;SAVE THE MUSIC STATUS WORD +.IIF NZ SITS, JSR PC,BRKMOF ;TURN OFF THE MUSIC BOX IF HE HAS IT + SPOP MUCWRD ;AND RESTORE IT + TST A ;IS IT CONTROL-Z? + BLT PAUS.R ;YES +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + JMP DEBUGL ;GO EITHER RETURN TO TOPLEVEL, OR ENTER BREAK LOOP + +PAUSE: +PAUS.R: PRTXT ^\PAUSE\ + JSR PC,PPLACE ;PRINT THE PLACE + JMP DBUGL1 ;AND ENTER BREAK LOOP + +BUG.R: PRTXT ^\HELP!!! LOGO BUG VERSION #\ + MOV #VERNF,A ;GET THE VERSION NUMBER + JSR PC,PRDN ;PRINT IT + SPACE ;PRINT A SPACE + TST DEBSW ;BEING DEBUGGED? + BEQ BUGBP1 ;NO +BUGBPT: BPT +BUGBP1: MOV LASTER,A ;GET THE ADDRESS + JSR PC,PRONL ;PRINT IT + JMP DEBUGL ;AND ENTER DEBUG LOOP + +CTIT.R: MOV TOPRNM,B ;GET THE PROCEDURE NAME + JMP PPNAME ;AND PRINT IT + +HNM.R: MOV B,A ;THE THING THAT HAS NO MEANING + BIC #7777,A ;GET THE TYPE + BIS #DPQF,FLAGS2 ;DONT PRINT " FOR AN ATOM + CMP A,#UFUN ;USER FUNCTION OR SYSTEM FUNCTION + BLOS 1$ ;YES + JMP PRPNM1 ;PRINT THE OTHER +1$: JMP PROAB ;PRINT THE NAME OF THE FUCTION + + +WTIB.R: MOV B,A ;LINE NUMBER SHOULD BE IN A + JMP PRDN ;AND PRINT IT + +TDE.R: MOV E,A ;TERMINAL NUMBER + JMP PRDN ;PRINT THE NUMBER + +PAE.R: MOV #UFUN,A ;THE TYPE + MOV TEMP,B ;THE NAME OF THE PROCEDURE + RTS PC ;AND RETURN + +WTAA.R: PUSHS A ;PUSH THE OUTPUT + RTS PC + +WTAB.R: PUSHS B ;PUSH IT ALSO + RTS PC + +NCF.R: MOV TOPS2,A ;WAS THERE A TAG? + BNE 1$ + MOV #LSTR,A ;PRINT EMPTY WORD +1$: PUSHS A ;TAG WE WERE LOOKING FOR + RTS PC + + + .SBTTL MISC ROUTINES +.GLOBL PPSWPO,PPSWPI +CACSAV: JSR PC,PPUSHT ;CAREFUL AC SAVE +ACSAV: MOV E,-(P) + MOV D,-(P) + MOV C,-(P) + MOV B,-(P) + MOV A,-(P) + JMP (F) + +CACRES: JSR PC,PPOPT ;CAREFUL AC RESTORE +ACRES: TST (P)+ + MOV (P)+,A + MOV (P)+,B + MOV (P)+,C + MOV (P)+,D + MOV (P)+,E + RTS F + +PPUSHT: CMP P,PPUSHL + BLOS 1$ + RTS PC +1$: JMP PPSWPO ;PDL REALLY OVERFLOWED + +PPOPT: CMP P,PPOPL + BHIS 1$ + RTS PC +1$: JMP PPSWPI + +SPUSHT: SUB #2,S + CMP S,SPUSHL + BLOS 1$ + RTS PC +1$: JMP SPSWPO + +SPOPT: ADD #2,S +SPOPT1: CMP S,SPOPL + BHI 1$ + RTS PC +1$: JMP SPSWPI + + + .SBTTL P AND S PDL POPPERS +PPTA: ;POP PP PDL TO (A) RELATIVE + ;USES A,F + SPOP F +PPTA1: CMP A,PRBAO + BHIS PPTA3 + MOV PPOPL,P + JSR PC,PPSWPI + BR PPTA1 +PPTA3: SUB PRBAO,A + SUB IP,A + NEG A + CMP A,P + BHIS 1$ + ERROR+FBUG ;OVER POPPING +1$: MOV A,P + JSR PC,PPOPT + JMP (F) +PSTA: ;POP S PDL TO (A) RELATIVE + ;USES A + CMP A,SPRBAO + BHIS PSTA3 + MOV SPOPL,S + JSR PC,SPSWPI + BR PSTA +PSTA3: SUB SPRBAO,A + SUB IS,A + NEG A + CMP A,S + BHIS 1$ + ERROR+FBUG ;OVER POPPING +1$: MOV A,S + JMP SPOPT1 + MLOOP: JSR PC,GETSTR + JSR PC,MREAD + BEQ MLOOP ;NO TOKEN LIST + JSR PC,EVLINE + BEQ MWDW + BR MLOOP ;LOOP BACK +MWDW: ERROR+WDW ;WHAT SHOULD I DOO WITH (S) + .SBTTL GET A STRING +GETSTR: +GETST0: JSR PC,RDSTR ;GET THE CHARACTERS FOR THE LINE INTO AN LSTR + BNE GETST1 ;GOT SOMETHING + TST RBRKF + BEQ GETST0 ;NOTHING, TRY AGAIN + ERROR+BRK ;ERROR OUT +GETST1: RTS PC + + +;CURRENT LINE POINTED TO BY A +LINSTP: PUSH GCHR ;SAVE THE PRINTING AND RECIEVING WORLD + SPUSH PCHR + SPUSH PRMTCH ;SAVE THE PROMPT CHARACTER + CLR PRMTCH ;DONT PROMPT AT ALL + MOV #TYI,GCHR ;RECIEVE CHARACTER FROM THE TTY + MOV #TYO,PCHR ;AND PRINT THE LINE THERE + MOV A,F ;GET THE POINTER TO THE CURRENT LINE + JSR PC,PRLN ;AND PRINT IT OUT + JSR PC,RDSTR ;READ A STRING + BEQ LINST1 ;EMPTYP, MIGHT BE A BREAK RECIEVED + POPS A ;IGNORE LINE TYPED IN +LINST2: + POP PRMTCH ;POP PROMPT AND REST OF WORLD + SPOP PCHR + SPOP GCHR + RTS PC +LINST1: TST RBRKF + BEQ LINST2 ;NOPE + POP PRMTCH ;NEED THE PROMPT CHARACTER + ERROR+BRK ;AND ERROR OUT + .SBTTL MORE READ ROUTINES!!! +MREAD: +MREAD1: CLR ILINEL + JSR PC,READ ;CONVERT CHAR STRING TO TOKEN LIST + BEQ MRD4 ;NO TOKENS + POPS A + MOV A,ILINEL ;GC PROTECT THIS CRUFT + JSR PC,WRTLIN ;WRITE LINE INTO THE COMMAND BUFFER + CLZ +MRD4: RTS PC + +CKSTG: ;CKECK IF DISC OR NODES ARE ALMOST GONE + BIT #DSAMFL,FLAGS2 + BNE CKSTG1 + CMP NNIFSL,#NBN + BHIS MRD4 + JSR PC,.GCOLL ;GC AND EXPAND IF NEEDED + CMP NNIFSL,#NBN + BHIS MRD4 +CKSTG1: CLR ERPROC + ERROR+NSL + +;WRITE LINE POINTED TO BY A INTO COMMAND BUFFER +WRTLIN: MOV #CURLIN+4+HEADER,C ;POINTER TO THE CURRENT LINE + CLR D ;COUNTER OF TOKENS +WRTLOP: JSR PC,.LOADA ;GET THE FIRST NODE IN A,,B + MOV B,(C)+ ;WRITE IT INTO THE BUFFER + INC D ;ONE MORE TOKEN + BIT #7777,A ;DONE? + BEQ WRTDON ;YES + CMP D,#INLEN ;HAVE WE DONE ALL OF THEM? + BNE WRTLOP ;NO +;HERE THE BUFFER IS FULL + ERROR+NAS ;NOT ENOUGH ARRAY SPACE (SHOULD BE TOO MANY TOKENS) +WRTDON: INC D ;SO THAT WE HAVE A LINE NUMBER + ASL D ;WANT A BYTE COUNT + MOV D,CURLIN+HEADER ;AND PUT IN THE LENGTH + MOV #HEADER,CTP + MOV #CURPNT,CPBND ;MAKE CPBND POINT TO SOMETHING + ;THAT ALWAYS HAS CURLIN + RTS PC + .SBTTL EVAL 1 LINE +;EVAL THE LINE ON THE S PDL, +;IN THE NEW SCHEME, EVAL THE LINE POINTED TO BY CTP + +EVLINE: +;THIS IS A SUPER HACK TO MAKE CONTINUE WORK (SORT OF) + TST BRAKE + BEQ 2$ + ERROR+BRK +2$: + BIC #EVIFS,FLAGS + CLR CO + CLR NOR + CLR COF + CLR LO + JSR PC,IGNT +EVLI1: BIT #CRF,FLAGS + BNE EVLI2 + TST TOPRNM ;IN PROCEDURE? + BNE EVLI4 ;NO, JUST FORGET IT +EVLI6: JSR PC,EVAL + BEQ EVLI3 ;NO OUTPUT, OK + JSR PC,CKSTG + SEZ + RTS PC +EVLI3: JSR PC,CKSTG + BIT #CRF,FLAGS + BNE EVLI2 + JSR PC,GNT + BIS #RTF,FLAGS + BR EVLI1 +EVLI4: BIC #7777,A + CMP #SNUM,A + BEQ EVLI5 ;AN SNUM + CMP #INUM,A + BEQ EVLI8 ;AN INUM + CMP #LSTR,A + BNE EVLI6 ;NOT AN SNUM, INUM OR LSTR + JSR PC,.CLSIN ;CONVERT LSTR TO INUM + BEQ EVLI6 ;NOT NO. OR TOO BIG +EVLI8: BIT #SPDF,FLAGS ;IS THIS PROC DEF. BEING SKIPPED? + BNE EVLI2 + JSR PC,.CINSN ;CONVERT INUM TO SNUM + BEQ EVLI7 ;TOO BIG + TST B ;IS NO. TOO SMALL? + BGT 1$ + ERROR+LNTB +1$: BIC #RTF,FLAGS ;DONT WANT TO REPEAT THIS TOKEN +EVLI5: JSR PC,ADLN +EVLI2: CLZ + RTS PC +EVLI7: ERROR+LNTB ;LINE # TOO BIG + .SBTTL GET NEXT TOKEN +GNT: MOV CT,B ;GET THE OLD CURRENT TOKEN + BIT #RTF,FLAGS ;SHOULD WE REPEAT THIS TOKEN + BEQ GNT1 ;NO + BIC #RTF,FLAGS ;CLEAR THE FLAG + TST B ;END OF LINE? + BNE 1$ ;NO + BIS #CRF,FLAGS ;SAY IT IS +1$: MOV B,A ;COPY IT + RTS PC +GNT1: BIC #PTLPF,FLAGS ;SET FLAG FOR PARENS + CMP #$LLPAR,B ;IS IT "!(" + BEQ GNTPAR ;YES, OKAY + CMP #$LPAR,B ;IS IT "(" + BNE GNT3 ;NO, LEAVE THE FLAG CLEAR +GNTPAR: BIS #PTLPF,FLAGS ;SET THE PARENS FLAG +GNT3: DEC CLCNT ;DECREMENT THE NUMBER OF TOKENS LEFT ON THIS LINE + BMI GNT2 ;DONE WITH THIS LINE + MOV CTP,A ;GET THE NEXT TOKEN POINTER + ADD @CPBND,A ;MAKE IT UNRELATIVE + MOV (A)+,B ;GET THE TOKEN + ADD #2,CTP ;POINT TO THE NEXT TOKEN + CMP #$COMT,B ;IS IT A COMMENT + BEQ SKPCOM ;SKIP THE COMMENT +GNT4: MOV B,CT ;PUT THE TOKEN INTO CT + MOV B,A ;COPY IT FOR SOME APPLICATIONS + RTS PC +GNT2: BIT #CRF,FLAGS ;AT THE END OF LINE THE TIME BEFORE? + BNE 1$ ;YES, LOSER + BIS #CRF,FLAGS ;SAY AT END OF LINE + CLR B ;SAY NO MORE TOKENS + BR GNT4 ;FINISH UP +1$: ERROR+OOT ;OUT OF TOKENS +SKPCOM: DEC CLCNT ;GET THE NEXT TOKEN + BMI GNT2 ;END OF LINE + MOV (A)+,B ;GET THE NEXT TOKEN + ADD #2,CTP + CMP #$COMT,B ;IS IT A COMMENT? + BNE SKPCOM ;NO, JUST CONTINUE + BR GNT3 ;GET THE NEXT TOKEN + +IGNT: MOV CTP,B ;POINTER TO THE START OF THE LINE + ADD #4,CTP ;POINT TO THE FIRST TOKEN IN THE LINE + ADD @CPBND,B ;MAKE IT ABSOLUTE + BIC #CRF,FLAGS ;CLEAR THE END OF LINE FLAG + MOV (B),A ;GET THE NUMBER OF TOKENS IN THIS LINE + ASR A ;FROM BYTES TO WORDS + DEC A ;FOR THE LINE NUMBER + MOV A,CLCNT ;SET UP THE TOKEN COUNT + BEQ GNT2 ;SIGNAL END OF LINE IMEDIATELY + BIS #RTF,FLAGS ;REPEAT THIS TOKEN + BR GNT3 ;CONTINUE WITH THE REST OF THE LINE. + .SBTTL GARBAGE COLLECTOR + +MARKNI: SPUSH A + SPUSH B + BR MARKN4 +MARKN: SPUSH A ;MARK NODE(B) + SPUSH B +;DEBUGGING FEATURE + JSR PC,.LOAD ;ARE WE MARKING AN IDLE NODE + BIC #7777,A + CMP #IDLE,A + BNE 1$ + .BUG. +1$: MOV (P),B +; +MARKN4: MOV B,A + BIC #170000,A + BIC #177770,B + MOVB BMT(B),B + ASH #-3,A + ADD GCBITS,A + BITB B,(A) ;ALREADY MARKED? + BEQ MARKN1 ;NO +MARKN3: SPOP B + SPOP A + SEZ + RTS PC +MARKN1: BISB B,(A) +MARKN2: SPOP B + SPOP A + CLZ + RTS PC +MARKDN: ;SKIP IF NODE (B) IS MARKED + SPUSH A + SPUSH B + MOV B,A + BIC #170000,A + BIC #177770,B + MOVB BMT(B),B + ASH #-3,A + ADD GCBITS,A + BITB B,(A) ;MARKED? + BEQ MARKN3 ;NO + BR MARKN2 ;YES-SKIP + +MARKL: PUSH A ;MARK LIST + SPUSH B ;NODE ADDS IN B + SPUSH C + JSR PC,MKLIST + BR MARKV1 + +MARKV: PUSH A ;MARK VARIABLE + SPUSH B ;NODE ADDS IN B + SPUSH C + CLR A + MOV B,C + JSR PC,MARKF1 ;TREAT POINTER AS A FIRST PTR +MARKV1: SPOP C + SPOP B + POP A +MARKV2: RTS PC + +MARKF: MOV A,C ;MARK FIRST OF A DATUM (NODE) IN A,,B +MARKF1: BIT #DSAMFL,FLAGS2 + BEQ MARKF2 ;DISK NOT ALMOST FULL +.GLOBL MKSPSW + JSR PC,MKSPSW + CLR ERPROC + .IFNZ NDISP + ADD #2,S ;POP SNLIST OFF S PDL + .ENDC + ERROR+NSL +MARKF2: ASH #-11.,C + BIC #177741,C ;GET THE DATA TYPE + JMP @LMT(C) ;WHICH YOU MIGHT MARK ON + + .IFNZ NDISP +MKSNAP: JSR PC,MKDC ;MARK DISPLAY CODE + .ENDC +MKLIST: BIT #7777,B ;IS THIS NODE REALLY HERE? + BEQ MARKV2 ;NO. RETURN +MKL1: PUSH A ;SAVE BUTFIRST OF CURRENT (I.E. PARENT) NODE + JSR PC, MARKN ;MARK NEXT NODE + BEQ MKL2 + JSR PC,.LOAD ;GET NEXT NODE + JSR PC,MARKF ;MARK FIRST OF NEW NODE + JSR PC,MARKBF ;MARK BUTFIRST OF NEWTHIS NODE +MKL2: POP A + RTS PC + +MKATOM: ;MARK ATOM CELL BUT NOTHING INSIDE IT +MKINUM: JMP MARKNI + +GCDIE: ERROR+FBUG + +MARKBF: BIT #7777,A ;MARK BUTFIRST OF LIST + BEQ MARKV2 ;AT END OF LIST +MKBF1: MOV A,B + JSR PC, MARKN ;MARK NEXT NODE + BEQ MARKV2 ;ALREADY MARKED, QUIT + JSR PC,.LOAD ;GET NEXT NODE + JSR PC,MARKF ;MARK FIRST OF NEW NODE + BR MARKBF ;MARK BUTFIRST OF NEW NODE + + GCOLL: +.GCOLL: JSR F,ACSAV +.IF NZ METERS + SPUSH METERP + MOV #MTGCOL,METERP + TST MTFLAG + BNE 1$ + INC MTGCCN +1$: +.ENDC + PUSH GNCN + SPUSH GNCN+2 + SPUSH TMPBLK + JSR PC,LSBITM ;ON THE LSI IT MAY BE NESSECARY TO MAP IN THE BIT TABLE +.GCOL2: MOV GCBITS,A ;GARBAGE COLLECT + MOV #GCBTL/2,B ;CLEAR BIT TABLE +.GCOL1: CLR (A)+ + SOB B,.GCOL1 +;NOW MARK EVERYTHING POINTED BY OBLIST. DONT MARK OBLIST NODES YET + JSR PC,GNOLEI +MKUOBJ: JSR PC,GNOLE ;GET NEXT UOE PTR + BEQ MKTPS + MOV B,C + JSR PC,.LOADC ;GET THE NODE + MOV A,C +MKUOE: BIT #7777,C ;ONE OTHER NODE? + BEQ MKUOBJ ;NO + MOV C,B ;YES + JSR PC,MARKN ;MARK IT + JSR PC,.LOADC + MOV A,C + BIC #7777,A + CMP #FBIND,A + BEQ MKFB ;FUNCTION BINDING + CMP #VBIND,A + BEQ MKVB ;VARIABLE BINDING + CMP #ABIND,A + BEQ MKARR + CMP #SVBIND,A + BEQ MKSVB ;SWAPPED VB + CMP #DBIND,A ;DELETED PROC BINDING? + BEQ MKFB ;MARK LIKE REGULAR PROCEDURE BINGING + ERROR+FBUG ;BUG +MKVB: JSR PC,MARKV ;MARK VARIABLE + BR MKUOE +MKSVB: BR MKUOE +MKARR: TSTB 5(B) ;IS IT A POINTER ARRAY? + BNE MKUOE + MOV B,F ;POINT TO BEG OF ARRAY + MOV 2(B),-(P) ;PUSH COUNT + SUB #HEADER,(P) + ASR (P) + ADD #HEADER,F +MKAR1: MOV (F)+,B + JSR PC,MARKV + DEC (P) + BNE MKAR1 + TST (P)+ + BR MKUOE + +MKFB: SPUSH C ;POINTS TO NEXT BINDING + SPUSH E ;USED BY GNOLE + MOV PROEND(B),F ;THE END OF THE PROCEDURE + ADD B,F ;MAKE IT ABSOLUTE POINTER + MOV B,D ;POINTER TO THE START OF THE PROCEDURE + ADD #HEADER,D ;POINT TO THE FIRST LINE OF THE PROCEDURE + MOV D,E ;SHOULD BE POINTER TO START OF NEXT LINE +MKLINE: CMP D,F ;AT THE END OF THE PROCEDURE? + BEQ MKFBD ;YES, JUST CONTINUE WITH NEXT BINDING + BHI MKFBUG ;BUGGY IF WE ARE PAST IT + ADD (E)+,E ;POINT TO THE START OF THE NEXT LINE + ADD #4,D ;POINT TO THE START OF THE ELEMENTS FOR THIS LINE +MKNTOK: CMP D,E ;ARE WE AT THE END OF THIS LINE? + BEQ MKLINE ;YES, TRY THE NEXT LINE + BHI MKFBUG ;ERROR IF WE ARE BEYOND THIS POINT + MOV (D)+,B ;GET THE VARIABLE TO MARK + MOV B,C ;COPY IT FOR THE TYPE + JSR PC,MARKF1 ;MARK THE FIRST OF IT (THE WHOLE TOKEN) + BR MKNTOK ;NEXT TOKEN +MKFBD: SPOP E ;POINTER TO NEXT OBLIST ELEMENT + SPOP C + BR MKUOE ;MARK THE NEXT BINDING FOR THIS ATOM +MKFBUG: ERROR+FBUG + + ;MARK FROM GCMKL LIST +MKTPS: MOV #GCMKL,F +MKRNDM: MOV (F)+,B ;POINTER TO POINTER + BEQ MKSPDL ;LAST ONE + MOV (B),B ;REAL NODE ADDRESS + BEQ MKRNDM ;NOTHING THERE + BIT #170000,B ;IS TYPE FIELD BLANK + BEQ MKRND1 ;YES, MAKE IT LIKE LIST + JSR PC,MARKV ;MARK VARIABLE + BR MKRNDM +MKRND1: JSR PC,MKL1 + BR MKRNDM + + +MKSPDL: MOV IS,E +MKSP1: MOV -(E),B ;GET A S PDL WORD + CMP E,S ;END OF S PDL? + BLO MKSP2 ;YES + JSR PC,MARKV ;MARK S PDL WORD + BR MKSP1 +.GLOBL MKSSP +MKSP2: JSR PC,MKSSP ;MARK THE SWAPPED PART OF THE S PDL + + +.IFNZ COLOR + +MKPALETTE: ;Mark the palette. + MOV #PALETTE, E + MOV #PALMAX, F +MKPALUP: + MOV (E)+, B + JSR PC, MARKV + SOB F, MKPALUP +.ENDC + + + +;OK, NOW MARK ALL UOE'S THAT POINT TO FUNCION OR VARIABLE BINDING + JSR PC,GNOLEI +MKOBL: JSR PC,GNOLE ;GET NEXT UOE PTR IN B + BEQ MKOBL6 ;NONE LEFT + MOV B,C + JSR PC,.LOADC ;GET THE PNAME NODE + MOV B,D + BIT #7777,A ;DOES IT POINT TO ANYTHING? + BNE MKOBL2 ;YES, MARK IT + MOV C,B ;NO WAS IT MARKED? + JSR PC,MARKDN + BEQ MKOBL3 ;NO - LINK IT OUT + BR MKOBL7 ;YES - ALSO MARK PNAME & BUCKET PTR +MKOBL2: ; - MARK THE UOE ETC. + MOV C,B ; -THE UOE NODE + JSR PC,MARKN +MKOBL7: MOV D,B ; -THE PNAME LSTR + JSR PC,MARKL + MOV GNCN+2,B ; -THE BUCKET LIST NODE + JSR PC,MARKN + BR MKOBL + ;THIS UOE IS NOT MARKED AND POINTS TO NOTHING - LINK IT OUT +MKOBL3: MOV TMPBLK,C ;GET PTR TO PREDECESSOR NODE + BNE MKOBL4 ;NONE, SO UHCT WAS PRED. + MOV GNCN,-2(E) ;SO CHANGE IT + BR MKOBL5 +MKOBL4: MOV GNCN,A ;CHANGE PTR IN PRED NODE + JSR PC,.STP1 +MKOBL5: MOV C,GNCN+2 ;SO GNOLE WILL WORK + BR MKOBL +MKOBL6: + +.IFNZ NDISP + BIT #DISPF,DFLAGS ;IF GUY HAS DISPLAY + BEQ GCDIS2 + JSR PC,DSGCF ;GCOLL IT, TOO +GCDIS2: +GCDIS: +.ENDC +;FALLS THROUGH + ;FALLS IN + ;OK NOW RETURN ALL IN MARKED NODES + ;RA ADDS OF LIT MAP + ;RB NODE ADDS + ;RC ACTUAL ADDER OF NODE + ;RD BIT MAP + ;RE POINT TO LIST OF FREE STORAGE RECYCLED NODES + ;RF NUMBER NODES LEFT TO CHECK + ;START COLLECTING AT LUNN(LOWEST UNPROTECTED NODE #) + CLR E + CLR NNGC + MOV #NODESP,C ;NODE ZERO ADDRESS + MOV NODTOP,F + SUB C,F ;COMPUTE LEGNTH OF NODESP + ASR F + ASR F ;COMPUTE NUMBER OF NODES + CLR B ;NODE ZERO + MOV GCBITS,A ;BIT TABLE ADDR +GCRT2A: MOV (A)+,D ;GET NEXT WORD OF BIT MAP + SEC + ROR D + +GCRT2: BCS GCRT3 + CMP B,#LUNN + BLOS GCRT3 + TST E ;WE HAVE A FREE NODE; IS FIRST FREE FOUND? + BNE GCRT2B + MOV B,FREE ;NO, THIS IS IT + BR GCRT2C ;(NO LAST-FREE TO UPDATE) + +GCRT2B: BIS B,(E) ;ELSE: ,E ;THIS NODE IS NEW LAST-FREE +GCRT2C: MOV C,E + MOV #IDLE,(C)+ ;MAKE NEW IDLE NODE, POINTS NOWHERE + CLR (C)+ + INC NNGC + BR GCRT4 +GCRT3: CMP (C)+,(C)+ +GCRT4: INC B + DEC F + BLE GCRT5 + CLC + ROR D + BNE GCRT2 + BR GCRT2A + +GCRT5: MOV NNGC,NNIFSL +;DEBUGGING FEATURE + BIT #PNNLF,FLAGS2 + BEQ GCRT6 + CPRTXT ^/[NODES LEFT / + MOV NNGC,A + JSR PC,PRDN + PRTXTC ^/ ]/ +; +GCRT6: +GCRT7: POP TMPBLK + SPOP GNCN+2 + SPOP GNCN + CMP NNIFSL,#200. ;LESS THAN A BLOCK LEFT + BHIS 1$ + MOV NODTOP,-(P) ;SAVE OLD NODTOP + JSR PC,EXNODE ;EXPAND NODE SPACE + MOV (P)+,A + MOV A,B + SUB NODTOP,A + BEQ 1$ ;NOTHING ADDED + NEG A + ASH #-2,A ;NUMBER OF NODES ADDED + ADD A,NNIFSL + ADD A,NNGC + MOV B,C ;OLD NODTOP + SUB #NODESP,B + ASH #-2,B ;NUMBER OF FIRST NODE ADDED + MOV FREE,-(P) + MOV B,FREE + INC B + +3$: MOV B,(C) +2$: BIS #IDLE,(C)+ + CLR (C)+ + INC B + SOB A,3$ + SUB #4,C + MOV (P)+,(C) + BIS #IDLE,(C) + + +1$: +.IIF NZ METERS, POP METERP + JSR F,ACRES + SEZ + RTS PC + .SBTTL GET NEXT OBLIST ELEMENT +GNOLE: ;GET NEXT USER OBLIST ELEMENT - PTR + ;INPUT - VIA GNOLEI + ;OUTPUT - PTR TO THIS BUCKET IN B & GNCN + ; " " NEXT " " GNCN+2 + ; " " PRED " " TMPBLK + ; IF NO PREV BUCKET, TMPBLK = 0 + ;USES E. SKIPS UNTIL NO UOE PTRS LEFT + PUSH A + MOV GNCN,B + MOV GNCN+2,TMPBLK +GNOLE2: MOV B,GNCN+2 + BIC #170000,B + BEQ GNOLE1 + JSR PC,.LOAD ;GET NEXT PTR ON BUCKEN LIST + MOV A,GNCN + JMP SRETA +GNOLE1: CLR TMPBLK + MOV (E)+,B ;GET NEXT BUCKET LIST + BGE GNOLE2 + JMP RETA ;DONE +GNOLEI: MOV #UHCT,E + CLR GNCN + RTS PC diff --git a/src/nlogo/filing.110 b/src/nlogo/filing.110 new file mode 100755 index 00000000..0b6eeba5 --- /dev/null +++ b/src/nlogo/filing.110 @@ -0,0 +1,2118 @@ + .SBTTL NEW FILING + VERSIO + +.IFNZ FILDSK +;USER PRIMITIVE ROUTINES + +;DIRSET TAKES A LIST AND SETS THE CURRENT DIRECTORY + +.IIF NZ UNIX, .DIRSE: +DSET: JSR PC,SETNM ;GET NAME OF DIRECTORY +.IFNZ UNIX + SYS CHDIR + #NAME + BCC 1$ + ERROR+ENDR +1$: RTS PC +.IFF + BNE DSET1 ;INPUT IS A LIST + JMP COPDEF +DSET1: JSR PC,COPDEF +DIRSET: JSR PC,GNWRD ;GET A WORD FROM THE LIST + BNE 1$ ;ANY LEFT? + RTS PC ;NONE LEFT, DONE +1$: JSR PC,DIRGET ;GET NEXT ITEM FROM LIST + BR DIRSET ;AND CONTINUE WITH THE NEXT NAME + + +DIRGET: JSR PC,NNFNGT ;GET A FILE NAME + MOV #NAME,E +1$: TSTB (E)+ ;NO, FIND IT + BNE 1$ + DEC E + CMPB #';,-(E) ;IS THIS THE ROOT DIRECTORY? + BNE DIRGT1 + CLR NPATH ;WELL THEN PATH IS NIL + CMP #NAME+1,E ;JUST ROOT? + BHI DIRGT2 + BLO DIRGT8 ;DISK NAME + MOVB -(E),A ;NO, GET WHICH ROOT HE WANTS + SUB #60,A ;MAKE SURE HE TYPED A NUMBER + BLT DIRGT8 ;MAYBE IT IS A NAME + CMP DISKS,A ;NUMBER? + BLE DIRGT8 ;MAYBE A NAME +DIRGT9: +;FALLS THROUGH + ;FALLS IN +.IF NZ SITS + ADD #10,A ;GET TO THE ROOT CAPABILITIES + MOV A,CURROT +.IFF + JSR PC,CRTROT +.ENDC +COPROT: +DIRGT2: SAVE A + MOV CURROT,A +.IFNZ LSI + BNE 1$ + ERROR+NCD +1$: +.ENDC + JSR PC,COPCUR + REST A + RTS PC + +DIRGT8: +.IF NZ SITS + MOV #DNAMEP,A ;POINTER TO TABLE OF NAME POINTERS +2$: MOV (A)+,B ;POINTER TO A NAME + BNE 1$ + ERROR+BDD ;BAD DISK NAME +1$: MOV #NAME,C ;POINTER TO HIS NAME +3$: CMPB (C)+,(B)+ + BEQ 3$ + TSTB -1(B) ;END? + BNE 2$ + CMPB -1(C),#'; + BNE 2$ + SUB #DNAMEP+2,A ;GET NUMBER*2 + ASR A ;CAP NUMBER + BR DIRGT9 +.IFF + ERROR+BDD +.ENDC + + +DIRGT1: JSR PC,NAMMUE ;MUTATE TO NAME + JSR PC,DIRCHK + BNE 2$ + ERROR+ENDR +2$: RTS PC + .IFNZ LSI +CRTROT: ASL A + MOV ROTCPS(A),CURROT + BNE DIRGT2 ;WE ALREADY HAVE ONE + MOV A,ROTBLK + BIS #.FARUT,ROTBLK + SAVE <#-1,#ROTBLK,#.FACAP*400+0> + .INVOK ;TRY TO CREATE A ROOT CAP + BNE 1$ +2$: ADD #ROTCPS,A + JSR PC,DELCPC + JSR PC,FLSCUR + CLR CURROT + ERROR+GDE +1$: MOV (P),CURROT + REST ROTCPS(A) + JSR PC,COPROT ;COPY ROOT TO CURCAP + SAVE <#0,#BITS,@CURCPP> + BIS #.FAMU,(P) + .INVOK + BEQ 2$ + SAVE <,,@CURCPP> + BIS #.FAMB,(P) ;THSI IS THE BIT TABLE + .INVOK + BEQ 2$ + JMP FLSCUR +.ENDC + +;MUTATE @CURCPP TO NAME IN NAME; CLOBBERS F +NAMMUT: TST (P)+ + CLR -(P) + SAVE + MOV #NPATH,A +2$: TSTB (A)+ + BNE 2$ + MOVB #40,-1(A) + MOV #NAME,B +3$: CMP #NPATH+MAXPLN,A + BLOS 4$ + MOVB (B)+,(A)+ + BNE 3$ + REST + SAVE <#NAME,@CURCPP> + BNE 1$ ;DON'T MUTATE NUL CAP + ERROR+NCD +1$: BIS #.FAMU,(P) ;MUTATE IT + .INVOK + JMP (F) + +4$: ERROR+BDD + +NAMMUE: JSR F,NAMMUT + BNE 1$ + JSR PC,FLSCUR + ERROR+FNF +1$: RTS PC + +;COPY THE DEFAULT CAPABILITY INTO THE CURRENT CAPABILITY +COPDEF: SAVE B + MOV #PATH,A + MOV #NPATH,B +3$: MOVB (A)+,(B)+ + BNE 3$ + REST B + MOV DEFCAP,A + MOV DEFROT,CURROT +COPCUR: JSR PC,FLSCUR ;GET RID OF ANY CURRENT CAPABILITY + TST A ;IS THIS FOR REAL? + BEQ 2$ + SAVE <#-1,#0,A> ;TO COPY CAPABILITY + BIS #.CPYCP,(P) ;TO COPY + .INVOK + BNE 1$ + ERROR+GDE +1$: REST @CURCPP + RTS PC +2$: CLR @CURCPP + RTS PC + +.DIRSE: JSR PC,SETCHF ;SET TO A FREE CHANNEL + BIT #7777,@S ;CHECK NAME OF DIRECTORY ON S-PDL + BNE .DIRS1 + SPOPS A ;NOTHING TO DO + SEZ + RTS PC +.DIRS1: JSR PC,DSET ;SET THE DIRECTORY +USEENT: JSR PC,DIRGET ;SET UP FILES + JSR PC,FLSDEF ;OLD DEFAULT NO LONGER NEEDED + SAVE + MOV #NPATH,A + MOV #PATH,B +1$: MOVB (A)+,(B)+ + BNE 1$ + REST + MOV @CURCPP,DEFCAP + CLR @CURCPP + MOV CURROT,DEFROT + SEZ + RTS PC +.USE: BIT #7777,@S + BNE .USE1 + SPOPS A + SEZ + RTS PC +.USE1: CLR NPATH + JSR PC,SETCHF ;SET US TO A FREE CHANNEL +1$: MOV DEFROT,A +.IFNZ LSI + BNE 9$ + CLR A + JSR PC,CRTROT + MOV CURROT,DEFROT + BR 1$ +9$: +.ENDC + JSR PC,COPCUR ;MAKE THE DEFAULT ROOT BE THE CURRENT CAP + MOV #NAME,A + MOV #"US,(A)+ + MOV #"ER,(A)+ + MOV #'S,(A) + JSR PC,NAMMUE + JSR PC,SETNM + BEQ 3$ + JSR PC,DIRSET +3$: BR USEENT +.ENDC ;END IFZ UNIX, PATH IS ONE WORD + +.IFZ UNIX +ERINDX: +ERFI: JSR PC,EVAL ;GET THE FILE NAME OR PATH LIST + BEQ .DELET ;DIDN'T TELL ME WHAT TO DO + ERROR+UELX ;UNEXPECTED END OF LINE +.DELI: +.DELET: JSR PC,SETCHF + JSR PC,DSET + JSR PC,NNFNGT + JSR PC,NAMMUE + SAVE <,,@CURCPP> + BIS #.FADL,(P) + .INVOK + BNE 2$ + ERROR+GDE +2$: JSR PC,FLSCUR + SEZ + RTS PC + +FLSDEF: SAVE A + MOV DEFCAP,A + JSR PC,DELCAP + CLR DEFCAP + REST A + RTS PC +.IFF +ERFI: JSR PC,EVAL + BEQ .DELET + ERROR+UELX +.DELET: JSR PC,SETNM + SYS UNLINK + #NAME + BCC 1$ + ERROR+GDE +1$: RTS PC + +ERINDX: JSR PC,EVAL + BEQ .DELI + ERROR+UELX +.DELI: JSR PC,SETNM + SYS FORK + BR .DELI1 + MOV A,C ;SAVE KID +1$: SYS WAIT + CMP A,C ;RIGHT PROCESS? + BNE 1$ + TST B + BEQ 2$ + ERROR+ENDR +2$: RTS PC + +.DELI1: SYS EXEC + #.RMDIR ;ASCIZ "/bin/rmdir" + #.RMARG ; ARGUMENT VECTOR + MOV #1,A ;INDICATE FAILURE TO PARENT + SYS EXIT +.ENDC + +.IFNZ SITS ;THIS IS PRETTY USELESS ON THE LSI-11, EVEN WITH FLAKEY DISK +;MAIL PRIMITIVE. SENDS "MAIL" TYPED ON SCREEN TO PERSON SPECIFIED + ;BY INSERTING TEXT INTO HIS OWN MAIL FILE, IF ONE EXISTS + ;OR CREATING A NEW ONE IF ONE DOESN'T +MAIL: JSR PC,SETCH0 + MOV #10,A ;GET CAPABILITY TO ROOT DIRECTORY + JSR PC,COPCUR + SAVE <#0,#MAILNM,@CURCPP> ;MUTATE TO MAIL DIR. ENTRY IN ROOT DIR. + BIS #.FAMU,(P) + .INVOK + JSR PC,.OPNA3 ;OPEN MAIL FILE + MOV #.WRTEC,PCHR ;CHARS. IN BUFFER INTO OUTPUT DEVICE + PRTXTC ^/------/ +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + SAVE <#NAME,#-1> + .CRUSR ;GET SENDER'S NAME IN "NAME" + MOV #NAME,A + JSR PC,PRAS ;PRINT NAME POINTED TO BY A + JSR PC,.CRLF ;CARRIAGE RETURN, LINEFEED + JSR PC,UDATEG ;SET THE DATE + MOV #1,D + JSR PC,TYPE ;PRINT THE DATE + JSR PC,.SPACE + JSR PC,UTIMEG ;SET THE TIME + MOV #1,D + JSR PC,PRINT ;PRINT THE TIME + SPUSH PRMTCH ;SAVE NORMAL PROMPT CHARACTER + MOV #'_,PRMTCH ;NEW ONE IS "_" + MOV #TYO,PCHR +MAIL2: JSR PC,RDSTR ;READ A STRING + BEQ MAIL3 ;NO CHARACTERS TYPED + MOV @S,B ;POINTER TO STRING + JSR PC,.LOADB ;FIRST CHARACTER + CMP #'.,B ;IS IT A PERIOD? + BEQ MAIL1 ;YES (NO MORE INPUT) + JSR PC,..FILP + BR MAIL2 +MAIL1: SPOP PRMTCH ;GET BACK OLD PRMTCH ("?") + MOV #.WRTEC,PCHR + SPOPS A + PRTXTC ^/------/ + MOV #TYO,PCHR + JMP .WRTCL +MAIL3: BR MAIL2 ;BREAK CODING USED TO BE HERE +.ENDC + +.IFNZ UNIX +READPT: ERROR+TGD ;READ FROM PAPER TAPE DEVICE (SOMEDAY) +.IFF +READPT: JSR PC,SETCH0 + JSR PC,FILCHK + TST D ;ZERO ARGS? + BEQ READP1 ;JUST READ INTO WORKSPACE + CMP #1,D ;EXACTLY 1? + BEQ 1$ ;YUP + ERROR+WNA +1$: JSR PC,..OPNW ;OPEN FILE FOR OUTPUT + JSR PC,PTRCRT ;TRY TO CREATE A PTR + MOV F,TMPCP ;SAVE IN THE TEMP CAP +READP3: SAVE TMPCP + .BYTI ;READ FROM PT + BEQ READP2 ;DONE + REST D ;GET THE CHAR WE READ + JSR PC,.WRTEC ;WRITE TO FILE + BR READP3 + +READP2: REST A ;FLUSH CAP + JSR PC,DELTMP + JSR PC,.WRTCL ;CLOSE FILE + SEZ + RTS PC + +READP1: JSR PC,PTRCRT ;GET PAPER TAPE + JSR PC,FLSCUR + MOV F,@CURCPP + MOV #.PREAD,GCHR + BR .READ9 + +.PREAD: SAVE @CURCPP + .BYTI + BNE 1$ + MOV #TYI,GCHR + JSR PC,FLSCUR + CLR @FILFLP +1$: REST D + BIC #177600,D ;FLUSH HIGH BIT + RTS PC + +PTRCRT: SAVE <#-1,0,#.TRCAP*400> ;CREATE TAPE READER + .INVOK ;TRY TO GET + BNE 1$ ;READ INTO WORKSPACE + ERROR+DIU +1$: REST F + RTS PC +.ENDC + +.READ: JSR PC,SETCH0 + JSR PC,.READF ;OPEN THE FILE FOR READING +.READ1: MOV #.READCH,GCHR ;WHERE TO GET THE CHARACTERS +.READ9: MOV PC,REDFLG ;SAY WE ARE READING + SAVE TOPRNM ;SAVE POINTER TO PROCEDURE BEING DEFINED + BEQ 1$ ;BRANCH IF THERE WAS NONE + JSR PC,END ;FLUSH DEFINING PROCEDURE TEMPORARILY +1$: PUSHS ILINEL ;SAVE THE ILINE FOR LATER + JSR PC,SAVEVL ;SAVE EVAL + PUSH #0 ;THE NUMBER OF ARGUMENTS + JSR PC,SAVPPS ;SAVE THE PDL POINTERS + BIS #DORF,FLAGS ;SAY THIS IS A READ FRAME + BIS #1,CPDLP ;SAY IT IS A PROCEDURE TYPE PUSH +RMLOOP: CMP #TYI,GCHR ;ARE WE AT EOF? + BEQ RMLOO1 ;YES, FINISH UP + JSR PC,SETCH0 ;MAKE SURE WE READ FROM PROPER FILE + JSR PC,RDSTR ;PUSH A STRING ONTO THE STACK + BEQ RMLOO2 ;TRY AGAIN + JSR PC,MREAD1 ;READ IT, AND PUT INTO THE COMMAND BUFFER + BEQ RMLOO2 ;NO TOKENS, CHECK FOR BREAK + JSR PC,EVLINE ;EVALUATE THE LINE + BNE RMLOOP ;NO OUTPUT, JUST CONTINUE + ERROR+WDW ;DONT SAY WHAT TO DO WITH +RMLOO1: TST TOPRNM ;DONE, DEFINING A PROCEDURE? + BEQ 1$ ;NO, DONT WORRY ABOUT IT + JSR PC,END ;FINISH ITS DEFINITION +1$: MOV #2$,DOFRET ;DITTO + JMP POPVAR ;POP OFF THE READ FRAME +2$: REST B ;GET BACK OLD TOPRNM + BEQ 3$ ;NO PROCDEURE? + JSR PC,EDIT2 ;REENTER PROCEDURE DEFINITION MODE +3$: SEZ + RTS PC +RMLOO2: TST RBRKF ;BREAK? + BNE 1$ ;YES + CMP #TYI,GCHR ;STILL INPUTTING FROM FILE? + BEQ RMLOO1 ;NO, FINISH UP + BR RMLOOP ;GO BACK FOR MORE +1$: ERROR+BRK + +DELALC: JSR PC,FLSCUR + JMP DELTMP +.IFNZ LSI +UNMOUN: JSR PC,G1NARG + CMP #NDISKS,B + BHI 1$ + ERROR+BDD +1$: MOV #CURCAP,A + MOV #NCHNS,F +2$: BIT #FILNDK,FILFLG-CURCAP(A) ;IS THIS A NON-DISK CHANNEL? + BNE 3$ + JSR PC,CMPDKN ;IS THIS CHANNEL OPEN ON THE DISK BEING UNMOUNTED? + BNE 3$ +STLANC +ENGINS < PRTXT ^/Channel /> +ENDENG +FRINS < PRTXT ^/Le canal /> +ENDLAN + SUB #CURCAP,A + ASR A + JSR PC,PRDN +STLANC +ENGINS < PRTXT ^/ is still open. Close it before unmounting./> +ENDENG +FRINS < PRTXT ^/ est encore ouvert! Fermer le fichier avant de demonte./> +ENDLAN + PRCR + ERROR+BDD +3$: TST (A)+ + SOB F,2$ + ASL B ;GET DISK NUMBER + MOV ROTCPS(B),A + JSR PC,DELCAP + MOV ROTCPS(B),F + CLR ROTCPS(B) + CMP F,DEFROT + BNE 4$ + CLR DEFROT +4$: MOV #DEFCAP,A + ASR B + JSR PC,DELCDK ;DETE CAP IF ON DISK(B) + BNE 9$ ;WASN'T + CLR PATH ;NO LONGER ANY VALID PATH +9$: SEZ + RTS PC + +DELCDK: JSR PC,CMPDKN ;COMPARE B WITH DISK NUMBER OF CAP (A) + BNE 1$ + JSR PC,DELCPC ;DELETE AND CLEAR + SEZ +1$: RTS PC + +CMPDKN: TST (A) + BEQ 1$ + SAVE <,,(A)> + BIS #.FADI,(P) + $INVOK + TST (P)+ ;FREE BLOCK COUNT + CMP B,(P)+ ;DISK NUMBER + RTS PC +1$: CLZ + RTS PC +.ENDC + +DELCPC: SAVE A + MOV (A),A + JSR PC,DELCAP + REST A + CLR (A) + RTS PC + +.IFNZ FILDSK +PRFN.R: MOV #NAME,A + JMP PRAS + +GDE.R: +.IFZ UNIX + .GERRW ;GET NEWEST ERROR WORD + BEQ 1$ + REST <,DSKERW> +1$: +.IIF NZ ENG, MOV #ENGDER,A +.IIF NZ FR, MOV #FRDER,A +2$: TSTB (A)+ + BEQ 3$ ;END OF THE LINE + CMPB DSKERW,-1(A) ;IS THIS OUR THING? + BEQ 3$ ;YUP +5$: TSTB (A)+ ;SEARCH FOR ZERO + BNE 5$ + BR 2$ +3$: JMP PRAS ;PRINT THE STRING +.IFF + MOV errno,A ;EXTERNAL VAR PROVIDED BY UNIX + CMP A,sys_nerr ;NUMBER OF KNOWN ERRORS + BGE 1$ ;JUMP IF UNKNOWN + ASL A ;MAKE INDEX INTO WORD VECTOR + MOV sys_errlist(A),A ;GET POINTER TO TEXT STRING + JMP PRAS +1$: PRTXT ^/Unknown UNIX error!/ + RTS PC +.ENDC + + +.WRITE: JSR PC,SETCH0 + JSR PC,..OPNW + MOV #.WRTEC,PCHR + MOV PC,WRTFLG + JSR PC,SHOWAL + CLR WRTFLG + JSR PC,.WRTCL + MOV #TYO,PCHR + SEZ + RTS PC + + +.OPENR: JSR PC,CHNSE1 +.READF: JSR PC,OPENR + BNE 1$ + ERROR+FNF +1$: SEZ + RTS PC + +OPENR: +.IFNZ UNIX + JSR PC,SETNM +.IFF + JSR PC,DSET + JSR PC,NNFNGT +.ENDC + +FREADR: +.IFZ UNIX + JSR F,NAMMUT + BEQ FREAD1 + JSR PC,DIRCHK ;FILE OR DIRECTORY? + BEQ FREAD2 ;FILE + TST CHAN ;DIRETORY CAN ONLY BE OPENED ON CHANNEL ZERO + BEQ 1$ + JSR PC,FLSCUR + ERROR+IFN +1$: MOV #FILDIR!FILRED,@FILFLP ;DIRECTORY + MOV PC,DIRFLG ;THIS FLAG IS NONZERO TILL DBUF HAS GOTTEN THE END OF THE DIR + CLR DIRIGC ;NO BYTES + BR FREAD3 +.IFF + SYS OPEN + #NAME + 0 + BCC 1$ + ERROR+GDE +1$: MOV CHAN,B + ASL B + MOV A,.FLDSC(B) +.ENDC +FREAD2: MOV #FILRED,@FILFLP +.IFZ UNIX +FREAD3: TST CHAN + BNE FREAD4 + CLR BCHNG + MOV #DBUF,DBUFP + MOV #DBUF,DBDEND + CLR DBUFST + CLR DBUFST+2 ;SET UP INITIAL BUFFER +.ENDC +FREAD4: CLZ + RTS PC +.IFZ UNIX +FREAD1: JSR PC,FLSCUR + ADD #6,P + SEZ + RTS PC +.ENDC + +.READC: BIT #FILRED,@FILFLP ;IS ANYTHING OPEN FOR READING ON THIS CHANNEL? + BEQ 2$ ;NO +.IFNZ UNIX + MOV CHAN,D + ASL D + MOV .FLDSC(D),A + SYS READ + #RDBYTE + #1 + TST A + BEQ 4$ + BGE 9$ + ERROR+GDE +9$: MOVB RDBYTE,D + RTS PC +.IFF + TST CHAN ;BUFFERED CHANNEL? + BNE 3$ ;NO + CMP DBUFP,DBDEND ;HAVE WE REACHED THE END OF THE BUFFER + BNE 1$ ;GET A NEW CHAR + JSR PC,NEWBLK + BNE .READC ;GOT SOME CHARS +.ENDC +2$: CLR REDFLG ;NO LONGER READING +4$: JSR PC,.REDCL ;CLOSE THE FILE FOR READING + MOV #EOFCHR,D + RTS PC + +.IFZ UNIX +1$: MOVB @DBUFP,D + INC DBUFP + RTS PC + +3$: SAVE <@CURCPP> + .BYTI + BEQ 5$ ;CLOSE THE FILE AT EOF + REST D + RTS PC +5$: TST (P)+ ;POP OFF THE CAPABILITY + BR 4$ ;AND FAIL GRACELESSLY + +NEWBLK: BIT #FILDIR,@FILFLP ;IS IT A DIRECTORY? + BEQ 1$ ;NO + TST DIRFLG ;DONE WITH THE DIRECTORY? + BEQ 2$ ;YES, DONE + JSR F,ACSAV ;SAVE AC'S FOR DIRECTORY + JSR PC,DRBLKI + JSR F,ACRES + BR 3$ +1$: JSR PC,FLUSBF ;FLUSH THIS BUFFER + BNE 3$ ;GOT A NEW ONE, GO BACK FOR CHARACTERS +2$: SEZ + RTS PC +3$: CLZ + RTS PC + +FLUSBF: JSR PC,WRTBUF +REDBLK: MOV #DBUF,DBUFP + SAVE <,,@CURCPP> ;READ THE ACCESS POINTER + BIS #.FARP,(P) ;READ THE POINTER + $INVOK + REST + SAVE <#DBUF,#-DBUFL,@CURCPP> + .BLKI + BNE 1$ ;GOT A FULL BUFFER + SAVE A + MOV #.ERPEF,A ;ATTEMPT TO READ PAST EOF IS EXPECTED + JSR PC,DERCHK ;ANY OTHER ERROR IS BAD + REST A + MOV 4(P),DBDEND ;GET POINTER TO THE END OF THE DATA + ADD #6,P ;POP OFF THE CALL + CMP DBDEND,#DBUF ;GET ANYTHING + BNE 2$ ;GOT SOMETHING + SEZ ;EOF + RTS PC +1$: MOV #DBUF+DBUFL,DBDEND ;SET UP POINTER TO THE END OF THE DATA +2$: RTS PC + +WRTBUF: SAVE D + TST BCHNG ;BUFFER BEEN MODIFIED? + BEQ 1$ ;NOPE + SAVE ;SET POINTER TO START OF BUFFER + BIS #.FASP,(P) ;SET THE POINTER + $INVOK + MOV #DBUF,D ;GET POINTER TO THE LAST ACCURATE BYTE + SUB DBDEND,D ;GET THE NEGATIVE BYTE COUNT + SAVE <#DBUF,D,@CURCPP> + .BLKO ;OUTPUT IT + BNE 1$ ;DID IT + REST D + JMP .WRTDF ;DISK FULL +1$: REST D + CLR BCHNG ;BUFFER HASN'T CHANGED + RTS PC + + ;THIS ENTIRE PAGE IS IFZ UNIZ + ;THIS GETS PUT IN PCHR WHEN .POI RUNS AS COROUTINE OF .FILER +DIRHAC: DEC DIRIGN ;SHOULD WE IGNORE THIS CHARACTER? + BGE 2$ ;YUP + CMP DBUFP,#DBUF+DBUFL ;END OF BUFFER? + BHIS DRBLK1 + MOVB D,@DBUFP ;MOVE CHARACTER INTO DBUF + INC DBUFP ;UPDATE POINTER + INC DBDEND ;AND VALID BYTE POINTER +2$: RTS PC + +DRBLKI: MOV #DBUF,DBDEND ;NO VALID BYTES YES + MOV #DBUF,DBUFP ;AND POINTER + MOV CURCPP,DIRCAP ;WE WANT .POI TO USE CURCAP, NOT TMPCP + SAVE PCHR ;THESE NEED TO BE DIFFERENT FOR OUR COROUTINE + MOV #DIRHAC,PCHR ;PCHR SHOULD READ INTO THE BUFFER, NOT PRINT OUT + MOV P,DIRIGP + MOV DIRIGC,DIRIGN + CLR B ;TO DO POI RATHER THAN POTREE + JSR PC,SETCH0 ;SINCE WE WANT TO USE THE BUFFER + JSR PC,..POI + CLR DIRFLG +;NON-LOCAL RETURN FROM DIRHAC ENTERS HERE +DRBLK1: MOV DIRIGP,P + MOV #DBUF,DBUFP + ADD #DBUFL,DIRIGC + REST PCHR ;THESE SHOULD BE NORMAL WHEN CO-RTN NOT RUNNING + MOV #TMPCP,DIRCAP ;THIS GOES BACK TO NORMAL TOO + RTS PC +.ENDC ;END IFZ UNIX + +.OPENM: JSR PC,CHNSE1 +.IFNZ UNIX + MOV #2,.APMOD ;SAVE MODES FOR OPEN BELOW +.ENDC + JSR PC,.OPNAX ;OPEN APPEND THE FILE + BIS #FILRED,@FILFLP ;AND GIVE HIM READ ACCESS ALSO + SEZ + RTS PC + +.OPENA: JSR PC,CHNSE1 +.IFNZ UNIX + MOV #1,.APMOD ;ONLY ALLOW WRITING +.ENDC +.OPNAX: +.IFZ UNIX + JSR PC,DSET ;SETS DIRECTORY +.OPNA3: JSR PC,NNFNGT ;SET FILE NAME + JSR F,NAMMUT + BEQ .OPNA1 + JSR PC,DIRCHK ;DO WE HAVE A FILE OR A DIRECTORY? + BEQ .OPNA2 ;IF FILE, PROCEED + JSR PC,FLSCUR ;IF DIRECTORY, FLUSH THE CAPABILITY + ERROR+FNF ;AND COMPLAIN +.OPNA1: CLRB 1(P) ;FLUSH OLD FUNCTION + BIS #.FAAD,(P) ;TRY TO MAKE A NEW FILE + .INVOK + BNE .OPNA2 + ERROR+GDE +.OPNA2: CMP -(P),-(P) ;DUMMY + SAVE <@CURCPP> + BIS #.FARE,(P) + $INVOK ;READ THE END OF FILE + TST CHAN ;CHANNEL ZERO? + BNE 1$ ;NO, DON'T DO THIS STUFF + JSR PC,FREAD3 ;CLEAR MISC STUFF + MOV (P),DBUFST ;STORE AWAY THE BUFFER START + MOV 2(P),DBUFST+2 +1$: SAVE <@CURCPP> + BIS #.FASP,(P) ;SET THE POINTER TO THE END OF FILE + $INVOK +.IFF + JSR PC,SETNM ;GET FILENAME +4$: SYS INDIR ;OPEN OLD FILE + .APEND + BCS 1$ ;JUMP IF FILE NOT FOUND, SHOULD BE CREATED + JMP .OPNA1 ;EVERYTHING IS READY +1$: MOV errno,A ;GET ERROR CODE + CMP #2,A ;ENOENT - NO SUCH FILE + BEQ 2$ ;RIGHT, OK TO CREATE + ERROR+GDE ;ANYTHING ELSE, DON'T TRY +2$: SYS CREAT ;CREATE NEW FILE + #NAME + 0777 ;ANYONE CAN DO ANYTHING + BCC 3$ ;JUMP IF OK + ERROR+GDE +3$: SYS CLOSE ;CLOSE SO WE CAN REOPEN IN RIGHT MODE + JMP 4$ ;INFINITE LOOP IF I DON'T UNDERSTAND ERR CODES RIGHT + +.OPNA1: MOV CHAN,B ;STASH FILDES + ASL B + MOV A,.FLDSC(B) + SYS LSEEK ;GET TO EOF + 0 + 0 + 2 +.ENDC + MOV #FILWRT,@FILFLP ;SET OPEN FILE FLAG FOR WRITE + SEZ + RTS PC + QUEST: JSR PC,ONETYI + SPUSH D ;SAVE IT + JSR PC,.CRLF ;PRINT CR AND LINEFEED + SPOP D ;GET CHARACTER +.IFNZ FR + CMP #'O,D + BEQ QUEST1 + CMP #'O+40,D + BEQ QUEST1 +.ENDC +.IFNZ ENG + CMP #'Y,D ;IS IT "Y"? + BEQ QUEST1 + CMP #'Y+40,D ;IS IT SMALL Y +.ENDC +QUEST1: RTS PC + +.OPENW: JSR PC,CHNSE1 ;FOR NOW +..OPNW: +.IFNZ UNIX + JSR PC,SETNM +.IFF + JSR PC,DSET ;SET DIRECTORY + JSR PC,NNFNGT ;SET IT +.ENDC +.WRTF2: +.IFZ UNIX + CLR -(P) + SAVE <#NAME,@CURCPP> + BNE 1$ + ERROR+NCD +1$: BIS #.FAAD,(P) + .INVOK ;TRY TO PUT IT INTO THE DIRECTORY + BEQ .WRTF1 + JSR PC,FREAD3 ;TO CLEAR MISC STUFF +.IFF + SYS OPEN ;FIRST TRY TO LOOK IT UP + #NAME + 0 + BCS 1$ ;JUMP IF NO FILE FOUND + SYS CLOSE ;FILE EXISTS, GIVE BACK DESCRIPTOR + BR .WRTF1 ;ASK USER ABOUT REPLACEMENT +1$: SYS CREAT ;NO FILE, CREATE ONE + #NAME + #0777 ;ANYONE MAY DO ANYTHING + BCC 2$ ;WINNING + ERROR+GDE +2$: MOV CHAN,B ;SAVE UNIX FILE DESCRIPTOR + ASL B + MOV A,.FLDSC(B) +.ENDC + MOV #FILWRT,@FILFLP +.WRTF6: SEZ + RTS PC +.WRTF1: +.IFZ UNIX + MOV #.EEAE,A ;ENTRY ALREADY EXISTS ERROR IS OK + JSR PC,DERCHK ;SEE IF THE DIRECTORY FULL +.ENDC +STLANC +ENGINS +ENDENG +FRINS +ENDLAN + JSR PC,QUEST ;GET REPLY + BEQ 1$ ;OK, DELETE IT + ERROR+GDE ;ENTRY ALREADY EXISTS +1$: +.IFZ UNIX + MOV @CURCPP,A + MOV A,TMPCP ;SO IT WILL BE DELETEED ON ERROR + CLR @CURCPP + JSR PC,COPCUR ;COPY OLD CURCAP INTO CURCAP + CLRB 1(P) ;USE OLD STUFF ON STACK + BIS #.FAMU,(P) ;BUT MUTATE INSTEAD + .INVOK ;TRY TO GET TO OLD FILE + BNE .+4 +.WRTF9: ERROR+GDE ;???? + SAVE <#0,#0,A> ;CABILITY TO FILE + BIS #.FADL,(P) ;WANT TO DELETE + .INVOK + BEQ .WRTF9 + JSR PC,DELTMP ;FLUSH CAP TO FILE + BR .WRTF2 ;TRY AGAIN +.IFF + SYS UNLINK ;TRY TO DELETE THE FILE + #NAME + BCC 3$ ;JUMP IF OK + ERROR+GDE +3$: JMP .WRTF2 ;OK, TRY AGAIN +.ENDC + +.IFZ UNIX +DERCHK: $GERRW ;READ THE ERROR WORD, SHOULD NEVER FAIL + TST (P)+ ;POP USELESS ERROR ADDRESS + MOV (P),DSKERW ;SAVE DISK ERROR CODE + CMP (P)+,A ;IS THIS THE PERMISSIBLE ERROR? + BEQ 1$ + JSR PC,CLOSF + ERROR+GDE +1$: RTS PC +.ENDC + +.WRTEC: BIT #FILWRT,@FILFLP + BNE 1$ + BPT +1$: +.IFZ UNIX + TST CHAN ;ONLY CHANNEL ZERO IS BUFFERED + BNE .WRTUB + CMP DBUFP,#DBUF+DBUFL ;FINISHED THIS BUFFER? + BNE 3$ ;STILL STUFF LEFT + JSR PC,FLUSBF ;GET THE NEXT BUFFER +3$: MOV PC,BCHNG ;BUFFER CHANGED + MOVB D,@DBUFP + INC DBUFP + CMP DBUFP,DBDEND ;HAVE WE WRITTEN A BYTE THAT HASN'T BEEN TOUCHED BEFORE? + BLOS 2$ ;NOPE + MOV DBUFP,DBDEND ;UPDATE VALID DATA POINTER +2$: RTS PC +.IFF + MOV CHAN,A ;CHANNEL TO WRITE ONTO + ASL A ;POINTER TO WORD + MOV .FLDSC(A),A ;FILE DESCRIPTOR + MOVB D,RDBYTE ;CREATE ONE-BYTE "BUFFER" + SYS WRITE + #RDBYTE + 1 + TST A ;-1 IF ERROR, 0 IF NO BYTES WRITTEN, 1 IF ONE WRITTEN + BLE .WRTDF ;ANYTHING BUT 1 IS BAD + RTS PC +.ENDC + +.WRTDF: MOV @CURCPE,A ;GET ERROR ROUTINE + BEQ .WRDF1 ;NONE + JMP (A) +.WRDF1: TST CHAN ;ONLY DELETE ON CHANNEL ZERO + BNE 1$ + TST WRTFLG ;AND THEN, ONLY IF WRITING WORKSPACE + BEQ 1$ +.IFZ UNIX + SAVE <,,@CURCPP> + BIS #.FADL,(P) + .INVOK +.ENDC +1$: JSR PC,.CLSCH + ERROR+GDE + +.IFZ UNIX +.WRTUB: SAVE + .BYTO + BEQ .WRTDF + RTS PC +.ENDC + +.REDCL: +.WRTCL: +.IFZ UNIX + TST CHAN ;ONLY CHANNEL ZERO IS BUFFERED + BNE .CLSCH + JSR PC,WRTBUF ;WRITE OUT THE BUFFER IF NEEDED +.ENDC +.CLSCH: JSR PC,FLSCUR + SEZ + RTS PC + +FLSCUR: SAVE A +.IFNZ UNIX + MOV CHAN,A ;GET LOGO CHANNEL NUMBER + ASL A ;MAKE WORD POINTER + MOV .FLDSC(A),A ;GET UNIX FILE DESCRIPTOR + SYS CLOSE ;CLOSE IT +.IFF + MOV @CURCPP,A + JSR PC,DELCAP +.ENDC + REST A + CLR @CURCPP + CLR @FILFLP + RTS PC + +..FILP: MOV #PRINT,A + BR ..FIL2 +.FILET: MOV #TYPE,A + BR .FILP2 +.FILEP: MOV #PRINT,A ;PRINT INTO THE FILE +.FILP2: JSR PC,CHNSE1 +..FIL2: BIT #FILWRT,@FILFLP ;IS FILE OPEN FOR WRITE? + BNE 1$ ;YES + ERROR+NFO ;NO, INVALID FILE NAME +1$: SPUSH PCHR + MOV #.WRTEC,PCHR + MOV #1,D ;ONE ARG FOR PRINT OR TYPE + JSR PC,(A) ;PRINT OR TYPE THE CHARACTERS +.FILP1: SPOP PCHR + SEZ + RTS PC + +.FTYO: JSR PC,CHNSE1 + BIT #FILWRT,@FILFLP ;IS FILE OPEN FOR WRITE? + BNE 1$ ;YES + ERROR+NFO ;NO, INVALID FILE NAME +1$: JSR PC,G1NARG + MOV B,D + JSR PC,.WRTEC + SEZ + RTS PC + +.FILEW: JSR PC,CHNSE1 + BIT #FILRED,@FILFLP ;OPEN FOR READ? + BNE 1$ ;YES + ERROR+NFO +1$: JSR PC,G1NARG ;GET AN ARGUMENT + TST B ;ANYTHING + BGT .FILW2 ;YES, AND POSITIVE, GOOD STUFF + BEQ .FILW4 ;AT LEAST IT IS 0 + ERROR+WTA ;NEGATIVE IS USELESS +.FILW4: SPUSHS #LSTR ;RETURN EMPTY WORD +.FILW1: CLZ + RTS PC +.FILW2: JSR PC,BLSTI ;INIT THE LSTR +1$: JSR PC,.READC ;GET A CHACTER + BIT #FILRED,@FILFLP ;IS IT EOF? + BEQ .FILW3 ;YES, RETURN WHAT WE GOT + JSR PC,BLST ;ADD IT + SOB B,1$ +.FILW3: JSR PC,BLSTF ;FINISH IT + TST TOPS ;DID WE PUT ANY CHARS IN? + BEQ .FILW4 ;NO RETURN THE EMPTY WORD + SPUSHS TOPS + CLR TOPS + BR .FILW1 ;AND RETURN + +.FILER: JSR PC,CHNSE0 + BIT #FILRED,@FILFLP ;IS FILE OPEN FOR READ? + BNE 1$ ;YES + ERROR+NFO ;NO,INVALID FILE NAME +1$: SPUSH GCHR + MOV #.READC,GCHR + JSR PC,RQUEST + SPOP GCHR + CLZ + RTS PC + +.FTYI: JSR PC,CHNSE0 + BIT #FILRED,@FILFLP ;IS FILE OPEN FOR READ? + BNE 1$ ;YES + ERROR+NFO ;NO, INVALID FILE NAME +1$: JSR PC,.READC + MOV D,B + BIC #-400,B + JMP R1NARG + +.CLOSF: JSR PC,CHNSE0 +.CLOS0: MOV #TYI,GCHR ;RESET IT FOR TTY INPUT + CLR REDFLG ;CLEAR READFLAG + CLR WRTFLG ;CLEAR WRITE FLAG +CLOSF: BIT #FILWRT,@FILFLP ;IS FILE OPEN FOR WRITE? + BEQ 1$ + JMP .WRTCL +1$: BIT #FILRED,@FILFLP ;IS IT OPEN FOR READ? + BEQ 2$ + JMP .REDCL +2$: RTS PC + + +.FILEO: JSR PC,CHNSE0 + TST @FILFLP ;IS A FILE OPEN + BEQ 1$ ;NO + JMP RTTRUE ;RETURN TRUE +1$: JMP RTFALS ;RETURN FALSE + +LOGIN: +.IFZ UNIX + JSR PC,.USE ;GO DO A USE OF THE GIVEN ARGUMENT +.ENDC + ;THEN FALL IN TO READ THE INIT FILE IF ANY + +RINIT: JSR PC,SETCH0 +.IFZ UNIX + JSR PC,COPDEF +.ENDC + MOV #NAME,A +.IFNZ UNIX + MOV #"LO,(A)+ ;UNDER UNIX, "INIT" IS TOO VAGUE + MOV #"GO,(A)+ +.ENDC + MOV #"IN,(A)+ + MOV #"IT,(A)+ + CLR (A) + JSR PC,FREADR ;TRY TO READ THE FILE + BEQ RINIT1 ;LOSE + JSR PC,.READ1 ;GO READ INTO LOGO +RINIT1: RTS PC + +.IFZ UNIX +;PAGENO = THE UPT SLOT WE CAN USE +;PGADD = THE PAGE ADDRESS +;WE ALSO HAVE TO GET THE CAPABILITY +;BUFFER= THE ADDRESS OF A BUFFER +;POTREE AND POI ROUTINES + +.POTREE: MOV PC,B ;FLAG ALLOWS LISTING OF INFERIOR DIR'S. + BR POI.1 +.POI: CLR B ;SUPRESSES LISTING OF INFERIOR DIR'S. +POI.1: JSR PC,SETCHF +..POI: CMP DIRCAP,CURCPP ;IF DIRCAP POINTS TO CURCAP, .POI IS BEING USED AS A + BEQ POI.2 ; A COROUTINE FOR .FILER, & WANTS THE OPEN CURCAP DIR TO STAY + JSR PC,FILCHK ;FILE ALREADY OPNE? + JSR PC,COPDEF + MOV @CURCPP,TMPCP + BNE 1$ + ERROR+NCD +1$: CLR @CURCPP +POI.2: CLR A ;RECURSION DEPTH COUNTER + CMP -(P),-(P) + SAVE <@DIRCAP> ;GET DISK DATA + BIS #.FADI,(P) + $INVOK + REST + MOV #1,TF7 ;USED TO ACCUMULATE TOTAL BLOCKS, ALLOW FOR THIS DIR + JSR PC,PODIR ;LIST IT + MOV TF7,A + JSR PC,PRDN +STLANC +ENGINS < PRTXT ^\ blocks, \> +ENDENG +FRINS < PRTXT ^\ blocs, \> +ENDLAN + MOV FREEBL,A ;NUMBER OF FREE BLOCKS + JSR PC,PRDN ;PRINT NUMBER OF FREE BLOCKS ON DISK +STLANC +ENGINS < PRTXT ^\ free blocks on disk #\> +ENDENG +FRINS < PRTXT ^\ blocs libres sur le disque #\> +ENDLAN + MOV DSKNUM,A ;DISK NUMBER + JSR PC,PRDN ;PRINT DISK NUMBER + PRCR ;AND CAR-RET +DELTMP: MOV TMPCP,A + JSR PC,DELCAP + CLR TMPCP + RTS PC ;WE ARE DONE +.ENDC ;IFZ UNIX + +FILCHK: TST @FILFLP ;IS FILE OPEN? + BEQ 1$ ;NO + ERROR+FAO +1$: RTS PC + +.IFZ UNIX +DIRCHK: SAVE <#FILBLK,#10,@CURCPP> + BIS #.FARI,(P) + $INVOK ;FIND OUT IF WE'VE OPENED A FILE OR A DIRECTORY + BIT #.FADIR,FILBLK+2 ;WELL, WHICH? + RTS PC + +;STILL IFZ UNIX +;GIVEN DIRECTORY CAPABILITY, TREE FLAG AND LEVEL + +PODIR: CLR D ;NUMBER OF ENTRY BEING PROCESSED +PODIR0: +PODIR1: JSR PC,POENTB ;SET ACCESS TO ZERO AND GET ENTRY + SAVE ENTEOF ;SAVE EOF WORD ON THE STACK + MOV D,E ;SKIP SOME ENTRIES + BEQ PODI14 +PODIR2: CMP C,(P) ;CHECK EOF + BLO PODI10 +PODI12: TST (P)+ + RTS PC ;NO MORE ENTRIES SO RETURN +PODI10: JSR PC,POENTI + SOB E,PODIR2 ;SKIP ANOTHER ENTRY + BR PODI14 +PODIR3: CMP C,(P) + BHIS PODI12 + JSR PC,POENTI ;INPUT AN ENTRY +PODI14: MOVB ENTRY+1,F ;GET TYPE BYTE + BIC #177761,F ;GET TYPE FIELD + SAVE C + JMP @PODIRT(F) ;DISPATCH TO SERVICE ROUTINE + +PODIRL: BPT ;BUG LINKS NOT IMPLEMENTED + BR PODIRP ;JUST SKIP THE ENTRY +PODIRS: TST A ;ENTER HERE FOR SELF ENTRY + BEQ PODIR7 ;DON'T PRINT "I" AT TOP LEVEL + MOV A,F ;LEVEL IS IN A + SUB #2,F ;PRINT LEVEL-2 SPACES +PODIR4: BEQ PODIR6 ;DON'T TRY TO PRINT ZERO SPACES +PODIR5: JSR PC,PODIRB ;PRINT (F) BLANKS +PODIR6: SAVE D + MOV #'I,D + JSR PC,@PCHR + SPACE + REST D ;INDICATES INFERIOR DIRECTORY +PODIR7: MOV #-1,E + JSR PC,PODIRI ;PRINT NAME,VERSION, AND SIZE +PODIRP: INC D ;ENTER HERE FOR PARENT TYPE ENTRY + REST C + BR PODIR3 ;DO THE NEXT ENTRY + + + +;STILL IFZ UNIX +PODIRF: MOV A,F ;ENTER HERE FOR FILES + ADD #2,F ;NUMBER OF SPACES BEFORE NAME + JSR PC,PODIRB ;PRINT THE BLANKS + JSR PC,PODIRN + BR PODIRP ;PRINT REST OF INFORMATION +PODIRD: INC TF7 ;ALLOW FOR BLOCK TAKEN BY THE DIR + TST B ;ENTER HERE FOR DIRECTORY ENTRY + BNE PODIR8 + MOV A,F ;NUMBER OF PRECEDING SPACES + BR PODIR4 ;SUPPRESS LISTING OF INFERIOR DIRECTORY +PODIR8: MOV D,(P) + SAVE <@DIRCAP> ;SAVE THE WORLD + ADD #2,A ;INCREMENT THE LEVEL + SAVE <#-1,#0,@DIRCAP> + BIS #.CPYCP,(P) ;COPY THE CAP. + .INVOK + BNE 1$ + ERROR+GDE +1$: MOV @DIRCAP,@CAPSP + ADD #2,CAPSP + SPOP @DIRCAP + MOV #ENNAME,E ;PUT NAME FOR MUTATE INTO BUFFER +PODIR9: TSTB (E)+ + BPL PODIR9 ;MOVE THE NAME + BICB #200,-1(E) ;CLEAR BIT IN LAST CHARACTER + SAVE + MOV TVERN,A + BLT 1$ + MOVB #'#,(E)+ + MOV #POPRN,PCHR + JSR PC,PRDN +1$: REST + CLRB (E) ;ZERO BYTE AT END OF ASCII STRING + CLR -(P) + SAVE <#ENNAME,@DIRCAP> + BIS #.FAMU,(P) ;MUTATE THE NEW CAP. + .INVOK + BNE 2$ + ERROR+GDE +2$: JSR PC,PODIR ;LIST INFERIOR + CMP -(P),-(P) + SAVE <@DIRCAP> + BIS #.DELCP,(P) ;DELETE THE CAP. + $INVOK + SUB #2,CAPSP + CLR @CAPSP + REST <@DIRCAP,D> ;RESTORE WORLD + SUB #2,A ;DECREMENT THE LEVEL + INC D + REST C + JMP PODIR0 ;CONTINUE LISTING THIS DIRECTORY + +POPRN: MOVB D,(E)+ + RTS PC + + +;PRINT (F) BLANKS ON THE OUTPUT DEVICE + +PODIRB: SAVE + MOV #' ,D ;PUT ASCII BLANK IN D +PODIB1: JSR PC,@PCHR ;PRINT A CHARACTER + SOB F,PODIB1 + REST + RTS PC + +;STILL IFZ UNIX +POSET: SAVE + BIS #.FASP,(P) + $INVOK + RTS PC + +POENTB: CLR C ;SET TO BEGGINING OF DIR + JSR PC,POSET +POENTI: SAVE E + SAVE <#ENTRY,#-4,@DIRCAP> + .BLKI ;INPUT THE HEADER WORD AND VERN # + BNE 2$ +3$: ERROR+GDE +2$: MOV #TVERN+2,E ;WHERE THE REST OF THE THING GOES + MOV ENTRY,F ;HEADER WORD + BLT 1$ ;SKIP IF EOF, TIME+ DATE EXIST + MOV #ENNAME,E ;NOT DATE+TIME, REST OF ENTRY GOES HERE + CLR DATE +1$: INC F + BIC #177401,F ;SIZE OF THIS ENTRY + ADD F,C + SAVE E + SUB #4,F ;ALREADY READ THIS MUCH + NEG F + SAVE + SUB F,E ;GET THE END ADDRESS OF THE BUFFER + SUB #ENTEND,E + BLE 4$ ;THERE IS ROOM FOR ALL OF IT + ADD E,2(P) ;CAN ONLY READ PART OF IT IN +4$: .BLKI ;INPUT THE HEADER WORD AND VERN # + BEQ 3$ ;DISK ERROR + TST E ;DID WE READ IT ALL IN? + BLE 5$ ;YUP + JSR PC,POSET +5$: REST E + RTS PC + + +;STILL IFZ UNIX +;PRINT OUT A LINE OF INFORMATION ABOUT FILE +;(C)= POINTS TO ENTRY TO PRINT +;SAVE REGISTERS A,B,D + +PODIRN: MOV ENTEOF,F + ADD #1777,F ;ROUND UP TO BLOCK BOUNDARY + CLR E ;CLEAR HIGH PART + ASHC #3,E + ADD ENTEFH,E ;PAGE NUMBER + ASHC #3,E ;NOW LEGNTH IN BLOCKS +PODIRI: SAVE ;SAVE LEGNTH AND VERSION NUMBER + MOV #ENNAME,E +2$: MOVB (E),D + BIC #177600,D ;CLEAR TOP BIT OF BYTE + CMPB #'#,D + BEQ 8$ + CMPB #'",D + BEQ 8$ + CMPB #'>,D + BEQ 8$ + CMPB #'<,D + BNE 9$ +8$: MOV #'",D + JSR PC,@PCHR + MOVB (E),D +9$: JSR PC,@PCHR ;PRINT A CHARACTER + TSTB (E)+ ;LAST BYTE HAS 200 BIT SET + BPL 2$ + MOV TVERN,A + BLT 3$ ;NO VERSION NUMBER + MOV #'#,D + JSR PC,@PCHR + JSR PC,PRDN ;PRINT THE VERSION NUMBER +3$: REST ;PRINT THE BLOCK LEGNTH + BLT 1$ + SPACE + SPACE + ADD A,TF7 ;ACCUMULATE TOTAL + JSR PC,PRDN +1$: JSR PC,PRDAT + JSR PC,.CRLF + REST + RTS PC ;DONE WITH THIS ENTRY + +;STILL IFZ UNIX +;PRDAT PRINTS DATE & TIME, IF ANY +PRDAT: JSR F,ACSAV ;SAVE ALL REGISTERS + MOV #11,D ;TAB + JSR PC,@PCHR + MOV DATE,E ;PUT DATE IN E + BEQ 5$ ;IF NO DATE & TIME, RETURN + CMP #-1,E ;SEE IF INITIALIZED + BNE PRDAT1 ;GO ON IF INITIALIZED + SPACE + MOV #'-,D ;PRINT " -" IF NOT + JSR PC,@PCHR +5$: JSR F,ACRES ;RESTORE ALL REGISTERS + RTS PC + +;CONTROL INSTRUCTIONS FOR PRDAT2 +PRDAT1: MOV #DTTAB,B ;POINT TO BEG. OF DTTAB + JSR PC,PRDAT2 ;PRINT DATE IN E + MOV TIME, E ;PUT TIME IN E + JSR PC,PRDAT2 ;PRINT TIME + JSR F,ACRES ;RESTORE ALL REGISTERS + RTS PC + +;TABLE DRIVEN ROUTINE TO PRINT DATE & TIME SEGMENT BY SEGMENT + ;ZTYPE & PRDN TAKE ARGUMENT IN A +PRDAT2: MOV #3,C ;C IS LOOP INDEX +PRDAT3: MOV E,A ;PUT DATE OR TIME IN A + ASH (B)+,A ;SHIFT QUANTITY TO LOW BYTE + BIC (B)+,A ;ZAP ALL BUT RELEVANT BITS + ASH (B)+,A ;MULT. FACTOR: 0 EXCEPT FOR SEC/2 + CMP #3,C ;FIRST TIME THRU LOOP? + BEQ 1$ + JSR PC,ZPRDN ;PRINT WITH LEADING 0 IF < 10 + BR 2$ +1$: JSR PC,PRDN ;PRINT WITHOUT LEADING 0 IF < 10 +2$: MOV (B)+,A ;PICK UP DELIMITER CHARACTER + MOV A,D ;PUT CHARACTER IN D + JSR PC,@PCHR ;PRINT CHARACTER + SOB C,PRDAT3 ;DO NEXT SEGMENT +PRDAT4: RTS PC + .IFF +;UNIX VERSION OF DIRECTORY LISTING +.POI: SYS FORK + BR .POI1 + MOV A,C ;SAVE KID +1$: SYS WAIT + CMP A,C ;RIGHT PROCESS? + BNE 1$ + RTS PC + +.POI1: SYS EXEC + #.LS ;ASCIZ "/bin/ls" + #.LSARG ; ARGUMENT VECTOR + MOV #1,A ;INDICATE FAILURE TO PARENT + SYS EXIT + +.POTREE: + SYS FORK + BR .POTR1 + MOV A,C ;SAVE KID +1$: SYS WAIT + CMP A,C ;RIGHT PROCESS? + BNE 1$ + RTS PC + +.POTR1: SYS EXEC + #.FIND ;ASCIZ "/bin/find" + #.FIARG ; ARGUMENT VECTOR + MOV #1,A ;INDICATE FAILURE TO PARENT + SYS EXIT + +.ENDC ;END UNIX CONDITIONAL FOR POI,POTREE + + + +.CRIND: +.IFZ UNIX + JSR PC,SETCH0 + JSR PC,DSET ;SET THE DIRECTORY + JSR PC,NNFNGT ;GET THE NAME + SAVE <,#NAME,@CURCPP> + BNE 9$ + ERROR+NCD +9$: BIS #.FAAD,(P) + .INVOK ;TRY TO CREATE THE DIRECTORY + BNE 1$ + ERROR+GDE +1$: SAVE <#0,@CURCPP> + .WRDO ;MAKE FILE FILE 1 BLOCK LONG + BNE 2$ +3$: ERROR+GDE +2$: SAVE <,,@CURCPP> + BIS #.FAMD,(P) + .INVOK ;MAKE INTO A DIR + BEQ 3$ + JMP FLSCUR +.IFF + JSR PC,SETNM + SYS FORK + BR .CRIN1 + MOV A,C ;SAVE KID +1$: SYS WAIT + CMP A,C ;RIGHT PROCESS? + BNE 1$ + RTS PC + +.CRIN1: SYS EXEC + #.MKDIR ;ASCIZ "/bin/mkdir" + #.MKARG ; ARGUMENT VECTOR + MOV #1,A ;INDICATE FAILURE TO PARENT + SYS EXIT +.ENDC + + +.IFNZ LPF + .SBTTL LINEPRINTER AND PAPER TAPE ROUTINES +.IFNZ SITS ;NO TAPE PUNCH +WRITEP: MOV #.TPCAP*400,F ;CREATE TAPE PUNCH + BR LPRIN1 +.ENDC +LPRINT: JSR PC,LPSEL ;GET MW OR LP +LPRIN1: JSR PC,SETCH0 + JSR PC,FILCHK + TST D ;ZERO ARGS? + BNE LPRINF ;JUST WRITE OUT FILE + JSR PC,OPNDEV ;OPEN LPT OR PAPERTAPE + JSR PC,FORMFD + MOV PC,WRTFLG + MOV #TMPOUT,PCHR +.IF NZ LSI + CMP #.TTCAP*400,F ;WAS IT THE MULTIWRITER? + BNE 1$ ;NOPE + MOV #MWOUTC,PCHR +.ENDC +1$: JSR PC,SHOWAL + JSR PC,FORMFD + MOV #TYO,PCHR + JSR PC,DELTMP + CLR WRTFLG + SEZ + RTS PC + +LPRINF: CMP #1,D ;EXACTLY 1? + BEQ 1$ ;YUP + ERROR+WNA +1$: SAVE F + JSR PC,.READF +3$: REST F + JSR PC,OPNDEV +LINEP1: JSR PC,FORMFD ;FORMFEED IF LPT +;falls through + +;falls in +TRNBUF: TST BRAKE + BNE 1$ ;IF BRAKE, FINISH + JSR PC,NEWBLK ;GET A DISK BLOCK + MOV DBUFP,A + MOV A,B + SUB DBDEND,A ;GET NEGATIVE COUNT OF BYTES + BEQ 1$ +.IF NZ LSI + CMP #.TTCAP*400,F ;WAS IT THE MULTIWRITER? + BNE 10$ ;NOPE + NEG A +11$: MOVB (B)+,D + JSR PC,MWOUTC + SOB A,11$ + BR TRNBUF +10$: +.ENDC + SAVE ;OUTPUT TO THE LINEPRINTER + .BLKO ;OUTPUT THE BLOCK + BNE TRNBUF ;NO ERROR + JMP LPTERR +1$: JSR PC,FORMFD +DELWLD: JSR PC,DELALC ;DELETE ALL DISK CAPS + SEZ ;NO OUTPUT + RTS PC + +LPSEL: MOV #.LPCAP*400,F ;CREAT LINEPRINTER +.IF NZ LSI + TST MWTTY ;DO WE HAVE MULTIWRITER FOR A TTY? + BEQ 1$ ;NOPE + MOV #.TTCAP*400,F ;CREATE A TTY INSTEAD + CLR MWFLAG + MOV #200.,MWCNT +.ENDC +1$: RTS PC + +.IFZ CPF +CPSEL: CPDSEL: +FORMFD: CMP #.LPCAP*400,F + BNE 1$ + SAVE <#14,TMPCP> ;OUTPUT A FORMFEED + .BYTO + BEQ LPTERR +2$: RTS PC +1$: CMP #.TPCAP*400,F + BNE 2$ + SAVE A + MOV #100.,A +3$: SAVE <#0,TMPCP> + .BYTO + BEQ LPTERR + SOB A,3$ + REST A + RTS PC +.IFF +FORMFD: RTS PC + + +.ENDC +.IF NZ LSI +MWDRIB: MOV #DRIBFL,MWCOUT + BR MWOUT +MWOUTC: MOV #TMPOUT,MWCOUT +MWOUT: JSR PC,@MWCOUT ;OUTPUT THE CHARACTER + CMP #15,D ;CR? + BNE 1$ ;NOPE + CLR LPPOS ;PUT THE PRINTER HEAD BACK TO ZERO + INC LPLCNT + SAVE D + MOV #12,D + JSR PC,@MWCOUT + REST D + DEC MWCNT + BR 2$ +1$: INC LPPOS ;ONE MORE FROB ON PAPER + CMP LPPOS,LPLEN ;PAST LINE END? + BLT 2$ ;NOPE + SAVE D + MOV #15,D + JSR PC,MWOUT + REST D +2$: DEC MWCNT ;TIME TO SYNC UP? + BGT 4$ ;NOPE + MOV #200.,MWCNT + SAVE D + MOV #3,D + JSR PC,@MWCOUT ;SEND THE SYNC CHAR + REST D + TST MWFLAG ;HAVE WE ALREADY SENT ONE SYNC? + BEQ 3$ ;NOPE + SAVE +7$: CMP #TMPOUT,MWCOUT ;MW ON TMPCAP? + BNE 5$ ;NOPE + MOV TMPCP,F + JSR PC,MWACKI + BR 6$ +5$: SAVE + JSR PC,SETC17 + MOV @CURCPP,F + JSR PC,MWACKI + REST B + JSR PC,SETCHN + REST B +6$: REST +3$: MOV PC,MWFLAG +4$: RTS PC + +MWACKI: SAVE A + MOV #10000.,A +1$: SAVE <,,F> + BIS #.TTPEK*400,(P) + $INVOK + TST (P)+ + BGE 2$ + SOB A,1$ + CMP #TMPOUT,MWCOUT + BEQ 5$ + REST A + CMP -(P),-(P) + JMP DRIBER +5$: JMP LPTERR +2$: SAVE F + $BYTI + CMP #6,(P)+ + BNE 1$ +3$: +; SAVE <,,F> +; BIS #.TTPEK*400,(P) +; $INVOK +; TST (P)+ +; BLT 4$ +; SAVE F +; $BYTI +; TST (P)+ +; BR 3$ +4$: REST A + RTS PC +.ENDC + +TMPOUT: SAVE + .BYTO + BEQ LPTERR + RTS PC + +LPTERR: JSR PC,DELWLD ;DELETE THE WORLD + ERROR+DNR ;DEVICE NOT READY +OPNDEV: JSR PC,DELTMP + SAVE <#-1,MWTTY,F> ;OPEN SOME DEVICE. IF IT IS THE MULTIWRITER WE HAVE THE TTY # + .INVOK + BNE 2$ ;CANT + ERROR+DIU +2$: REST TMPCP +.IF NZ LSI + CMP #.TTCAP*400,F ;WAS THAT THE MW? + BNE 1$ ;NOPE + SAVE <,#.TIMGO+.TIMGI,TMPCP> ;SET THE STATUS TO IMAGE IN AND OUT + BISB #.TTMOV,1(P) ;DO A MOVE INTO THE STATUS WORD + $INVOK +.ENDC +1$: RTS PC +.ENDC ;END LSICOND + +.IFNZ UNIX +LPRINT: CMP #1,D ;MUST HAVE A FILE ARG + BEQ 1$ ;OK + ERROR+WNA ;(SITS LOGO TAKES 0 ARGS BUT NOT UNIX) +1$: JSR PC,SETNM ;READ FILENAME TO PRINT + SYS FORK + BR .LPRI1 + MOV A,C ;SAVE KID +2$: SYS WAIT + CMP A,C ;RIGHT PROCESS? + BNE 2$ + RTS PC + +.LPRI1: SYS EXEC + #.LPR ;ASCIZ "/bin/lpr" + #.LPARG ; ARGUMENT VECTOR + MOV #1,A ;INDICATE FAILURE TO PARENT + SYS EXIT +.ENDC + +;ROUTINES FOR HANDLING MULTIPLE CHANNELS +;SET TO A FREE CHANNEL +SETCHF: SAVE + MOV #NCHNS*2+FILFLG-2,B ;AVOID USING DRIBBLE CHANNEL + MOV #NCHNS-1,C +1$: TST -(B) + BEQ 2$ + SOB C,1$ + ERROR+IFN +2$: SUB #FILFLG,B + ASR B + REST C + BR SETCH1 + +SETC17: SAVE B + MOV #NCHNS-1,B + BR SETCH1 + +SETCH0: SAVE B + CLR B +SETCH1: JSR PC,SETCHN + REST B + RTS PC + +SETCHN: CMP B,#NCHNS + BLO 1$ + ERROR+WTA +1$: MOV B,CHAN ;SET CHANNEL NUMBER + ASL B + ADD #CURCAP,B + MOV B,CURCPP + ADD #FILFLG-CURCAP,B + MOV B,FILFLP + ADD #FILERR-FILFLG,B + MOV B,CURCPE + RTS PC + +;COME HERE TO SET CHANNEL WHEN DEFULAT # OF ARGS IS 0 +CHNSE0: CLR C + BR CHNSET + +;COME HERE WHEN DEFAULT IS 1 ARG +CHNSE1: MOV #1,C +CHNSET: MOV D,B ;NUMBER OF ARGS + SUB C,B ;GET NUMBER OF EXTRA ARGS SUPPLIED + BEQ 1$ ;IF ZERO DO A SETCHN TO 0 + BLT 2$ ;IF NEGATIVE ERROR OUT + DEC B ;THERE SHOULD BE EXACTLY ONE EXTRA + BNE 2$ ;NOPE, ERROR +3$: JSR PC,G1NARG ;GET CHANNEL NUMBER +1$: JMP SETCHN ;SET THE CHANNEL +2$: ERROR+WNA + +.IFZ UNIX +DELCPS: MOV #NCHNS-1,C +1$: MOV C,B + JSR PC,SETCHN + JSR PC,CLOSF + DEC C + BGE 1$ +.IFNZ LSI + MOV #ROTCPS,A +2$: JSR PC,DELCPC + TST (A)+ + CMP #ROTCPS+,A + BNE 2$ + CLR DEFROT ;NO LONGER ANY DEFAULT ROOT +.ENDC + RTS PC +.ENDC + +FILPOS: JSR PC,CHNSE0 + TST @FILFLP + BNE 9$ + ERROR+NFO +9$: +.IFZ UNIX + TST CHAN ;BUFFERED? + BEQ 2$ ;YES + SAVE <,,@CURCPP> + BIS #.FARP,(P) ;READ THE POINTER + $INVOK + REST ;GOT, RETURN IT + BR 1$ +2$: MOV DBUFP,B ;GET THE POINTER INTO THE BUFFER + SUB #DBUF,B ;GET THE NUMBER OF BYTES TO THE POINTER + MOV DBUFST,A ;GET THE HIGH ORDER START OF THE BUFFER + ADD DBUFST+2,B ;ADD ON THE LOW ORDER + ADC A +1$: +.IFF + MOV CHAN,A ;GET LOGO CHANNEL NUMBER + ASL A ; AS WORD POINTER + MOV .FLDSC(A),A ;GET UNIX FILE DESCRIPTOR + SYS LSEEK ;SEEK TO CURRENT POSITION + 0 + 0 + 1 ;RETURN WITH 2-WD POINTER IN A AND B +.ENDC +FILEO1: JSR PC,GRBAD ;MAKE NODE UP WITHT THE NUMBER IN IT + BIS #INUM,C ;POINT TOT HE NUMBER + JMP ORTC ;RETURN IT + +FILEOF: JSR PC,CHNSE0 + TST @FILFLP + BNE 9$ + ERROR+NFO +9$: +.IFZ UNIX + JSR PC,GETFLP ;JUST GET THE EOF + TST CHAN ;BUFFERED? + BNE FILEO1 ;NOPE, JUST RETURN SYSTEM EOF + MOV DBUFST,C ;HIGH ORDER START OF BUFFER + MOV DBUFST+2,D ;LOW ORDER + MOV DBDEND,E ;GET BUFFER END + SUB #DBUF,E ;GET COUNT OF BYTES IN BUFFER + ADD E,D ;ADD IN BUFFER END + ADC C + CMP A,C ;IS THE SSYTEM EOF AFTER THE INTERNAL EOF? + BHI FILEO1 ;YES, USE SYSTEM EOF + BLO 2$ ;NO, USE INTERNAL EOF + ;HAVE TO COMPARE LOW PARTS + CMP B,D + BHI FILEO1 ;SYSTEM EOF IS HIGHER +2$: MOV D,B + MOV C,A + BR FILEO1 +.IFF + MOV CHAN,A ;HO HUM GET UNIX FILDES + ASL A + MOV .FLDSC(A),A + MOV A,C ;SAVE FOR NEXT SYS CALL + SYS LSEEK ;GET CURRENT POINTER + 0 + 0 + 1 + MOV A,.LSOF1 ;SAVE FOR LATER RESTORE + MOV B,.LSOF2 + MOV C,A ;GET BACK FILDES + SYS LSEEK + 0 + 0 + 2 + MOV A,D ;RING AROUND THE ACS + MOV C,A ;GET FILDES ONCE MORE + MOV D,C ;GET POINTER TO EOF IN C,D + MOV B,D + SYS INDIR ;SEEK BACK TO WHERE WE WERE + #.LSEEK + BR FILEO1 +.ENDC + + +.IFZ UNIX +GETFLP: SAVE <,,@CURCPP> + BIS #.FARE,(P) + $INVOK ;GET FILE LENGTH + REST ;B IS LOW ORDER, A IS HIGH + RTS PC +.ENDC + +.DRIB: JSR PC,SETC17 +.IFNZ UNIX + MOV #1,.APMOD ;ONLY ALLOW WRITING +.ENDC + JSR PC,.OPNAX +.DRIB1: MOV #DRIBFL,DRIBF +.DRIB2: MOV #DRIBER,@CURCPE ;SET ERROR ROUTINE + SEZ + RTS PC + +DRIBER: MOV #SRTSPC,DRIBF + CPRTXT + JSR PC,CLOSF + CMP (P)+,(P)+ ;FLUSH ARGS TO BYTO + RTS PC ;RETURN TO DRIBFL + +.IFNZ CPF +PRTON: JSR PC,SETC17 + JSR PC,FILCHK + JSR PC,LPSEL ;MULTIWRITER OR LP + JSR PC,OPNDEV ;OPEN ON TMPCP + MOV TMPCP,@CURCPP + CLR TMPCP + MOV #FILNDK!FILWRT,@FILFLP +.IF NZ LSI + TST MWTTY ;MULTIWRITER? + BEQ .DRIB1 ;NOPE + MOV #MWDRIB,DRIBF + BR .DRIB2 +.IFF + BR .DRIB1 +.ENDC + +PRTOFF: +.ENDC +.NODRI: JSR PC,SETC17 + JSR PC,CLOSF + MOV #SRTSPC,DRIBF + SEZ + RTS PC + + +DRIBFL: SAVE + JSR PC,SETC17 + JSR PC,.WRTEC +DRIBF1: REST B + JSR PC,SETCHN + REST B + RTS PC + +.IF NZ LSI +MULTIW: JSR PC,G1NARG + MOV B,MWTTY + SEZ + RTS PC +.ENDC + +;COMPARES (A),(B) AND SETS FLAGS AS NEEDED +DBLCMP: CMP (A),(B) ;COMPARE A AND B + BNE 1$ ;NOT EQUAL, COMPARE ON THE TOP PARTS + CMP 2(A),2(B) ;COMPARE THE LOWER PARTS +1$: RTS PC + +.SETFI: JSR PC,CHNSE1 + TST @FILFLP ;ANYTHING OPEN? + BNE 1$ ;YEP + ERROR+NFO +1$: JSR PC,G1IARG ;GET THE ARGUMENT TO SET TO +.IF NZ UNIX + MOV B,.LSOF1 ;SAVE ARG IN BLOCK FOR UNIX + MOV C,.LSOF2 + MOV CHAN,B ;GET FILDES + ASL B + MOV .FLDSC(B),A + SYS INDIR ;SEEK THERE + #.LSEEK + BCC 2$ ;JUMP IF OK + ERROR+BDD +2$: SEZ + RTS PC +.IFF + SAVE ;SAVE THE NEW POINTER + MOV P,B ;B POINTS TO THE ARGUMENT +SETFI1: SAVE ;SAVE THE BUFFER START IN DOUBLE PRECISION + MOV CHAN,F ;GET THE CHANNEL, AND SEE IF BUFFERED + BNE SETFI2 ;NO, JUST COMPARE THE EOF + MOV P,A ;B POINTS TO THE END + JSR PC,DBLCMP ;COMPARE THE START OF THE BUFFER WITH THE ARG + BHI SETFI2 ;FLUSH THE BUFFER, THE ARG IS BEFORE THE BUFFER + MOV DBDEND,C ;POINTER TO THE END OF THE VALID DATA BYTES + SUB #DBUF,C ;MAKE IT CORRECT NUMBER OF VALID BYTES + ADD C,2(P) ;ADD THE NUMBER OF VALID BYTES TO GET THE EOF OF THE FILE + ADC (P) ;ADD IT ON + JSR PC,DBLCMP ;COMPARE AGAINST THE END OF THE BUFFER + BHIS SETFI3 ;WE WIN, THE END OF THE BUFFER IS HIGHER THAN THE ARG +SETFI2: JSR PC,GETFLP ;GET THE EOF INTO A,,B + MOV A,(P) ;PUT IN THE HIGH ORDER + MOV B,2(P) ;COMPARE IT AGAINST THE ARG + MOV P,A ;A POINTS TO THE EOF + MOV P,B ;B POINTS TO THE ARGUMENT + CMP (B)+,(B)+ + JSR PC,DBLCMP ;COMPARE THE EOF WITH THE ARGUMENT + BHIS 1$ ;OKAY + ERROR+BDD +1$: TST F ;IS IT BUFFERED? + BNE 2$ ;NO + JSR PC,WRTBUF ;WRITE THE BUFFER +2$: ADD #4,P ;POP OFF THE END OF BUFFER + SAVE @CURCPP ;SAVE THE FILE CAPABILITY + BIS #.FASP,(P) ;SET THE FILE POINTER + $INVOK + TST F ;BUFFERED? + BNE 3$ ;NO + JSR PC,REDBLK ;READ THE BLOCK +3$: SEZ + RTS PC ;AND RETURN +SETFI3: ADD #4,P ;POP OFF THE END OF THE BUFFER + REST ;GET BACK THE ARGUMENT + SUB DBUFST+2,B ;DOUBLE PRECISION SUBTRACT + SBC A + SUB DBUFST,A ;GET THE OFFSET FROM THE START OF THE BUFFER INTO B + BEQ 1$ ;SHOULD BE ZERO (HIGH PART) + BPT +1$: ADD #DBUF,B ;GET POINTER INTO DBUF + MOV B,DBUFP ;SET IT UP + SEZ + RTS PC +.ENDC + +.IFNZ SITS ;NOT AVAILABLE ON THE LSI-11 RIGHT NOW +LOAD25: JSR PC,SETCH0 + MOV S,A ;GET POINTER TO THE S PDL + MOV (A),B ;EXCHANGE THE TWO ARGUMENTS + MOV 2(A),(A)+ + MOV B,(A) + JSR PC,UGTTYG ;GET THE USER TTY + BEQ MYTTY + SAVE E ;SAVE THE TTY NUMBER + JSR PC,.READF ;READ THE FILE NAME + MOV (P),E ;RESTORE THE TTY NUMBER + MOVB TTYCPS(E),E ;GET THE CAPABILITY NUMBER TO THIS TTY + BIC #177400,E ;CLEAR OUT THE TOP BYTE +LOAD26: JSR PC,.READC ;GET A CHARACTER + CMP #EOFCHR,D ;EOF? + BEQ LOAD27 ;YES + TST BRAKE ;BREAKING? + BNE LOAD28 ;YES + SAVE ;PUT IT ON THE STACK + $BYTO ;OUTPUT IT + BR LOAD26 ;CONTINUE UNTIL END OF FILE +LOAD28: JSR PC,CLOSF ;CLOSE THE FILE +LOAD27: REST E ;GET BACK TTY NUMBER + JMP CLOSE1 ;CLOSE THE TTY, AND RETURN +MYTTY: JSR PC,SETTIM + JSR PC,.POF + JMP RESTTY +.ENDC + +.POFILE: JSR PC,EVAL + BNE .POF + ERROR+UELX + + +.POF: JSR PC,SETCH0 + TST @FILFLP ;IS ZERO FREE? + BEQ 1$ ;YUP + JSR PC,SETCHF ;IF NOT, USE SLOWER UNBUFFERED CHANNEL +1$: JSR PC,.READF +.POF1: JSR PC,.READC + TST BRAKE + BNE .POF2 + BIT #FILRED,@FILFLP + BEQ .POF2 + JSR PC,@PCHR + BR .POF1 +.POF2: JMP CLOSF + +.ENDC ;END OF LSICOND + +.IFZ UNIX ;THIS IS FOR LIST-FORMAT PATHNAMES +GNWRD: ;INPUT POINTER TO LIST OF WORDS ON S + ;OUTPUT -IF LIST IS NOT EMPTY, + ; POINTER TO FIRST OF LIST ON TOP OF S + ; POINTER TO BF OF LIST NEXT + ; Z WILL BE CLEAR + ; -IF LIST IS EMPTY, POP S AND SET Z + ;IF F LIST ISNT A WORD, WTA ERROR ISSUED + JSR F,CACSAV + MOV @S,B + BIT #7777,B ;IS LIST EMPTY? + BEQ GNWRD1 + JSR PC,.LOADB ;NO GET 1ST NODE + MOV A,@S ;SAVE BF ON S + PUSHS B ;YES - PUSH FIRST ON S + JSR F,CACRES + CLZ + RTS PC +GNWRD1: POPS A ;EMPTY LIST QUIT + JSR F,CACRES + SEZ + RTS PC + +LSTRCV: MOV @S,B ;POINTER TO FILE NAME IN B + MOV #LSTR,A ;DATA TYPE FOR CONVERSION + JSR PC,CONVER ;MAKE NAME AN LSTR + BNE 1$ + ERROR+WTA ;INVALID FILE NAME (CONVERSION FAILED) +1$: JMP SPOPT ;POP THE THING OFF THE STACK + +NNFNGT: MOV #NAME,E +NFNGET: ;INPUT ADDRESS OF BLOCK IN E + ; PTR TO LSTR ON S + ;OUTPUT PUT 1ST 10. CHAR OF LSTR INTO BLOCK + ; SET 200 BIT IN LAST CHAR, POP S + JSR F,CACSAV ;SAVE REGISTERS + JSR PC,LSTRCV ;CONVERT TO LSTR +; MOV B,@S ;POINTER TO NEW DATA ON STACK (HOPEFULLY THIS IS USELESS) + BIC #170000,B ;LEAVE DATA TYPE + MOV B,GNCN ;"GET NEXT CHARACTER" NODE + MOV #10.,C ;TAKES ONLY THIS MANY CHARACTERS +NFNG1: JSR PC,GNC ;GET NEXT CHAR + CMP #15,D ;UGH! (IS IT A CARRIAGE RETURN?) + BEQ NFNG2 ;YES- NO MORE CHARACTERS + MOVB D,(E)+ ;STORE THE NEXT CHARACTER + MOV D,TEMP + SOB C,NFNG1 ;KEEP GOING UNTIL WE HIT TEN +NFNG2: CLRB (E) ;CLREAR LAST BYTE + JSR F,CACRES ;GET BACK THE OLD REGISTERS + RTS PC +.ENDC ;END IFZ UNIX + +.IFNZ LSI&FILDSK +;MAGIC LSI CHAIN COMMAND +.CHAIN: + JSR PC,LOGBYE ;CLEAN UP WORLD + MOV P,E + SUB #40,E ;TAKE SOME PDL SPACE + SAVE E + JSR PC,NFNGET ;GOBBLE THE NAME + RESET ;FLUSH ALL INTERUPTS + MOV (P),@RMEMT ;PUT POINTER AT THE TOP OF THE WORLD + MOV (P)+,F ;RANDOM PLACE FOR PDL + TST -(F) + JMP 173002 +.ENDC + SETNM: ;INPUT LIST OR WoRD ON S + ;OUTPUT IF WORD, OUTPUT WORD AND SET Z + ; IF LIST, OUTPUT LAST AND BL OF LIST ON S + ; PUT BL ON TOP AND CLEAR Z + ; OTHERWISE ERROR +.IF NZ FILDSK + JSR PC,FILCHK +.ENDC +1$: JSR F,CACSAV ;SAVE REGISTERS + MOV @S,C ;GET INPUT + BIT #7777,C + BNE 2$ + ERROR+IFN ;INVALID FILE NAME +2$: MOV C,B ;SEE IF IT'S A LIST + BIC #7777,C + CMP C,#LIST + BEQ SETNM1 ;YES, IT IS +SETNM2: JSR F,CACRES ;OK, SET Z AND QUIT + SEZ + RTS PC +SETNM1: +.IFNZ UNIX + ERROR+IFN +.IFF + JSR PC,COPYL ;COPY LIST - INPUT IN B + ;OUTPUT IN B; C POINTS TO LAST NODE IN NEW LIST + ; E POINTS TO 2ND TO LAST NODE + JSR PC,.LDP2 + MOV A,@S + MOV E,C + BEQ SETNM3 ;NO BUTLAST + JSR PC,.LDP1 ;FIX UP LINK + BIC #7777,A + JSR PC,.STP1 + BIS #LIST,B +SETNM4: PUSHS B + JSR F,CACRES + CLZ + RTS PC +SETNM3: MOV #LSTR,B + BR SETNM4 +.ENDC + \ No newline at end of file diff --git a/src/nlogo/gtfun.89 b/src/nlogo/gtfun.89 new file mode 100755 index 00000000..4ff4517e --- /dev/null +++ b/src/nlogo/gtfun.89 @@ -0,0 +1,558 @@ +.IF NZ GTL!NDISP!TVS +; OUTPUT B MOD 360 IN B. +; ALWAYS OUTPUTS A POSITIVE NUMBER +MOD360: TST B + SXT A + DIV #360.,A ;DIVIDE B BY 360 + TST B ;REM >= 0? + BGE 1$ + ADD #360.,B ;IF REMAINDER WAS NEGATIVE, ADD 360 TO IT +1$: RTS PC + ;TAKES FNUM POINTED TO BY F, AND PUTS IT IN A NODE + ;RETURNS POINTER TO IT IN B +WHOPIE: SPUSH C + MOV (F)+,A ;PUT FNUM IN A AND B + MOV (F)+,B + JSR PC,GRBAD ;PUT FNUM IN NODE SPACE + BIS #FNUM,C ;SET APPROPRIATE TYPE + MOV C,B ;PUT POINTER IN B + SPOP C + RTS PC + +.ENDC + +.IIF NDF LSI,DC LSI,0 ;FOR INSERT INTO OLOGO + .SBTTL 2500 DISPLAY STUFF + VERSIO +.IFNZ GTL + +NOGTL: CLR GTLDF +.IIF NZ LSI,CLR LSTVEE + SEZ + RTS PC + +.IIF NDF HOME, HOME: +GTHME: MOV #GTHOME,B + JSR PC,GT1WRD ;SEND OUT THE HOME TO THE 2500 +GCLXYA: MOV GTDIZF,GTDIZY ;TURTLE ISN'T DIZZY + MOV #DCURX,A ;WE WILL CLEAR OUT X, Y AND ANGLE + MOV #6,C +1$: CLR (A)+ + SOB C,1$ + BR GTSRTS + +GT1WRD: JSR PC,GTTEST + CMP #GTUDIS,GTLDF ;DISPLAY? + BNE GT2NWD ;LET HIM SEND ANYTHING HE WANTS + CMP GTLEN,GTDLTP ;ABOUT TO HIT SNAPS? + BLT GT2NWD + ERROR+TML ;YUP, TOO MANY LINES! +GT2NWD: INC GTLEN +GTWRD: JSR PC,GTOUT +GTSRTS: SEZ + RTS PC + +.IIF NDF SHOWTU, SHOWTU: +GTSHOW: MOV #GTSTUR,B + BR GT1WRD + +.IIF NDF HIDETU, HIDETU: +GTHIDE: MOV #GTHTUR,B + BR GT1WRD + +.IIF NDF PENUP, PENUP: +GTPU: BIS #PENUF,DFLAGS ;SET PEN UP +GTPU1: MOV #GTPENU,B + BR GTPENM + +.IIF NDF PENDOW, PENDOW: +GTPD: MOV #GTPEND,B + BIC #PENUF,DFLAGS ;SET PEN DOWN +GTPENM: CMP #GTUPLT,GTLDF ;PLOTTER? + BNE 1$ ;NO, IGNORE +.IIF NZ LSI, JSR PC,PWAIT ;WAIT FOR PLOTTER TO SETTLE +1$: BR GT1WRD + +BLINK: MOV #GTBLNK,B + BR GT1WRD + +.IIF NDF LAMPON,LAMPON: +GTLON: MOV #GTLPON,B + BR GT1WRD + +.IIF NDF LAMPOF,LAMPOF: +GTLOFF: MOV #GTLPOF,B + BR GT1WRD + +USEDIS: +GTLDIS:.IIF NZ LSI,MOV PC,LSTVEE +GTLDI1: MOV PC,GTLDF ;SAY WE ARE A GTL DISPLAY + CLR DFLAGS ;FLUSH OLD WRAP AND PEN FLAGS + CLR GTNEW ;ASSUME NOT NEW + MOV #GTCS,B ;CLEAR THE SCREEN + JSR PC,GT2NWD + CLR B + SOB B,. ;WAIT FOR THE OLD 2500 + JSR PC,GTWIPE + MOV #GTRUB+3775,B ;OLD STYLE RUBDIS 3 + JSR PC,GT2NWD ;THIS CROCK CAUSES OLD 2500'S TO IGNORE THE NEXT 3 COMMANDS + JSR PC,UTURGT + JSR PC,GETTUR + BLT 1$ + MOV PC,GTNEW +1$: JSR PC,UDISGT +GTSRT2: SEZ + RTS PC + +.IIF NDF STARTT,STARTT: +USETUR: JSR PC,GTLDIS +UTURGT: MOV #GTUTUR,B +UDEVGT: MOV B,GTLDF + JMP GT1WRD + + +UDISGT: MOV #GTUDIS,B + MOV B,GTLDF + JSR PC,GT1WRD + JSR PC,GTWIPE + JMP GTCLEA + +.IIF NDF STRTPL,STRTPL: +USEPLO: JSR PC,GTLDIS + MOV #GTUPLT,B + BR UDEVGT + +.IFZ UNIX +GETTUR: JSR PC,GETTYP ;ANY CHARS? + BLT 1$ + JSR PC,ONETYI ;EMPTY OUT THE BARFER + BR GETTUR +1$: MOV #GTGTST,B ;GET TURTLE STATE + JSR PC,GT1WRD ;SEND THE COMMAND + MOV #50.,A +GETTU1: JSR PC,GETTYP + BGE 1$ + SOB A,GETTU1 + MOV #-1,D + RTS PC +1$: JMP ONETYI + +GETTYP: CMP -(P),-(P) + SAVE TYICP + MOVB #.TTPEK,1(P) + $INVOK ;FIND OUT IF THERE IS A CHARACTER + TST (P)+ ;NEGATIVE IF NONE + RTS PC +.IFF +GETTUR: CLR A ;STANDARD INPUT + SYS GTTY ;GET CURRENT MODES + #.GTTY + BCC 1$ ;JUMP IF OK (PRIMARY INPUT IS TTY) + MOV #-1,D ;BAD, CAN'T GET TO DISPLAY TURTLE + RTS PC +1$: SYS STTY ;SET MODES: NOOP BUT WAITS FOR IDLE + #.GTTY ; AND FLUSHES UNREAD INPUT + MOV #GTGTST,B ;COPIED FROM SITS VERSION + JSR PC,GT1WRD + SYS SIGNAL ;PREPARE TO TAKE ALARM INT + 14 ;SIGALRM + 1 ;IGNORE (ODD NUMBER) + MOV #2,A ;1 TO 2 SECOND DELAY + SYS ALARM ;ROLLING + JSR PC,ONETYI ;CAN RETURN -1 IF ALARM TIMES OUT + CLR A ;GOT SOMETHING, NOW CLEAR CLOCK + SYS ALARM + RTS PC +.ENDC + +.IIF NDF CLEARS, CLEARS: +GTCLEA: MOV #GTCS,B + JSR PC,GTOUT ;REALLY OUTPUT THE CLEAR + BIC #PENUF,DFLAGS ;SET PEN DOWN + CLR GTLEN ;THE DISPLAY LIST IS ZERO LENGTH + JSR PC,GCLXYA ;CLEAR X Y AND ANGLE + JMP CHINIT ;INIT DLIST-CHANGE STUFF + +.IIF NDF WIPECL, WIPECL: +GTWIPE: MOV #GTSLEN,GTSNBT ;FLUSH ALL SNAPS + MOV #GTSLEN-10.,GTDLTP ;SET TOP OF DISPLAY LIST + TST GTNEW + BEQ 1$ ;OLD + CLR GTSNBT ;SNAP BOTTOM ALWAYS (RELATIVE) ZERO + MOV #GTMNDS-10.,GTDLTP ;TOP IS HERE (AND STAYS THERE!) +1$: BR GTSRT2 ;AND RETURN + +;dpointer routines + +dpoint: cmp gtdptr,#gtdtop ;out of dpointer index slots? + blos 1$ + error+wta +1$: mov gtdptr,b + bis #gtdpoi,b ;send dpointer command to 2500 + jsr pc,gtout + mov gtdptr,b ;inc dpointer index and return old index + inc gtdptr + jmp r1narg + +change: mov s,f ;swap change's 2 args + mov (f),-(p) + mov 2(f),(f) + mov (p)+,2(f) + + jsr pc,g1narg ;1st arg is dlist pointer + cmp b,gtdptr + blo 2$ + error+wta +2$: bis #gtchan,b + jsr pc,gtout ;send the change command to the 2500 + + jsr pc,run ;now run the sentence given by the 2nd arg + + mov #gtendc,b ;send the endch command to the 2500 + jsr pc,gtout + sez ;no deposit, no return + rts pc + +chinit: clr gtdptr + rts pc + +SPIN: MOV #GTSPIN,F +GT11BD: MOV PC,GTDIZY ;TURTLE IS DIZZY +GT11BT: JSR PC,G1NARG +GT11B1: JSR PC,GTTEST + SAVE B + MOV B,C + BIC #1777,C ;CLEAR GOOD BITS + ASH #-10.,C ;EXTEND SIGN + BEQ 1$ ;ZERO + INC C + BEQ 1$ ;1 + ERROR+WTA +1$: BIC #174000,B ;CLEAR UNUSED BITS + BIS F,B + JSR PC,GT1WRD + REST B + SEZ + RTS PC + +MOVE: MOV #GTMOVE,F + BR GT11BD + +.IIF NDF SETHEA, SETHEA: +GTSETH: JSR PC,G1NARG +GTSET1: MOV #GTSHED,F + JSR PC,GT11B1 + MOV B,DCURA +GTSRT1: JMP GTSRTS + +.IIF NDF RIGHT, RIGHT: +GTRIGH: JSR PC,G1NARG +GTRTLT: MOV #GTRT,F + JSR PC,GT11B1 + MOV DCURA,A + ADD A,B + JSR PC,MOD360 + MOV B,DCURA + BR GTSRT1 + +.IIF NDF LEFT, LEFT: +GTLEFT: JSR PC,G1NARG + NEG B + BR GTRTLT + +.IIF NDF FORWAR, FORWAR: +GTFORW: JSR PC,G1ARG +GTFDBK: SETI + SETF + LDF FA,FC ;TEMP INTO FC + TST GTDIZY ;TURTLE ALREADY DIZZY? + BNE 1$ + STF FA,-(P) + LDCIF DCURA,FA + SUBF #41664,FA + NEGF FA ;GET 90-HEADING + STF FA,-(P) ;SAVE "REAL" ANGLE + JSR PC,SINDEG ;GET SIN OF ANGLE + STF FA,FB ;SAVE SINE IN FB + LDF (P)+,FA + STF FB,-(P) + JSR PC,COSDEG + LDF (P)+,FB + LDF (P)+,FC ;GET BACK LENGTH + MULF FC,FA ;GET X OFFSET + MULF FC,FB ;AND Y OFFSET + ADDF DCURX,FA + ADDF DCURY,FB + SETI + CMP #GTUPLT,GTLDF ;PLOTTER? + BEQ 9$ ;ALWAYS WRAP + CMP #GTUTUR,GTLDF ;TURTLE? + BEQ 1$ ;NEVER WRAP +9$: BIT #WRAPF,DFLAGS + BNE 1$ + STF FA,FF + LDCIF #200.,FD + JSR PC,GTCHKB + STF FB,FF + JSR PC,GTCHKB +1$: STCFI FC,B ;BACK TO INTEGER +.IFNZ LSI + CMP #GTUPLT,GTLDF ;PLOOTER? + BNE 2$ + JSR PC,PLOTTM ;IF PLOTTER, COMPUTE TIME TAKEN +.ENDC +2$: MOV #GTFD,F + JSR PC,GT11B1 + STF FA,DCURX + STF FB,DCURY + SEZ + RTS PC + +GTCHKB: ABSF FF + CMPF FF,FD ;IS IT < 400.0? + CFCC + BLE 1$ + ERROR+OOB +1$: RTS PC + +.IIF NDF BACK, BACK: +GTBACK: JSR PC,G1ARG + NEGF FA + BR GTFDBK + +GT10CH: SAVE A + MOV GTDLTP,A + SUB GTLEN,A + CMP #10.,A + BLT 1$ + ERROR+TML +1$: REST A + RTS PC + +.IIF NDF SETXY, SETXY: +GTSXY: MOV #GTSTXY,F +GTSXY1: JSR PC,G2NARG + JSR PC,GT10CH ;CHECK THAT THERE IS LOTS OF ROOM +GTSXY2: SETI + SETF + LDCIF B,FA + STF FA,DCURX + JSR PC,GT11B1 + MOV A,B + LDCIF B,FA + STF FA,DCURY + JMP GT1WRD + +DELTAX: MOV #GTDLXY,F + BR GTSXY1 + + +SETSNA: JSR PC,G1NARG + TST GTNEW + BNE 1$ + SUB #GTSLEN,B +1$: MOV B,GTSNBT ;FLUSH SOME SNAPS + SEZ + RTS PC + +OSNAP: TST GTNEW + BNE 1$ + MOV #GTSNAP,B + JSR PC,GT1WRD + JSR PC,G1NARG +2$: MOV #1,GTLEN + JMP GT1WRD + +1$: JSR PC,G1NARG + ADD #GTNSNP,B + BR 2$ + +DIZZY: JSR PC,G1NARG + MOV B,GTDIZY + MOV B,GTDIZF ;SET DIZZY FLAG + SEZ + RTS PC + +.IIF NDF SNAP, SNAP: +GTSNP: TST GTNEW + BNE GTNWSN + MOV GTSNBT,E ;BOTTOM OF SNAPS + SUB GTLEN,E ;NEW BOTTOM OF SNAPS + SUB #2,E ;ROOM FOR POPJ + CMP E,GTLEN ;DOES IT COLLIDE WITH XISTING LIST? + BGT 1$ ;NO +2$: ERROR+TML +1$: CMP E,#GTMNDS ;WILL IT BE BELOW THE MINIMUM ALLOWED? + BLE 2$ + MOV E,GTSNBT ;SET NEW BOTTOM + SUB #10.,E + MOV E,GTDLTP ;SET NEW TOP FOR DISPLAY LIST + MOV #GTSNAP,B + JSR PC,GT1WRD + MOV GTSNBT,B ;GET ADDRESS FOR SNAP + ADD #GTSTRT,B ;ADD IN OFFSET + JSR PC,GT1WRD + MOV GTSNBT,B +GTRSNP: MOV #1,GTLEN ;NEW LENGTH IS JUST 1 WORD + JMP R1NARG ;RETURN NUMBER WHERE SNAP WAS STORED + +GTNWSN: MOV GTSNBT,E ;BOTTOM OF SNAPS + MOV E,A + ADD GTLEN,A + ADD #2,A + CMP #GTNEND,A ;PAST THE END? + BHI 1$ + ERROR+TML +1$: MOV A,GTSNBT ;SET NEW BOTTOM + MOV #GTNSNP,B + ADD E,B + JSR PC,GT1WRD + MOV E,B + BR GTRSNP + +.IIF NDF DISPLA, DISPLA: +GTDIS: JSR PC,GT10CH + TST GTNEW + BNE 1$ + MOV #GTDISP,B + JSR PC,GT1WRD + JSR PC,G1NARG + ADD #GTSTRT,B ;OFFSET TO START OF DISPLAY AREA + JSR PC,GT1WRD + BR 2$ +1$: JSR PC,G1NARG + BIT #176000,B + BEQ 3$ + ERROR+TML +3$: ADD #GTNDIS,B + JSR PC,GT1WRD +2$: TST GTDIZY ;DIZZY? + BNE 9$ ;YUP, THIS STUFF WON'T HELP + JSR PC,GTPU1 ;PUT UP PEN + SETI + LDF DCURX,FB + LDF DCURY,FA + STCFI FB,B + STCFI FA,A + MOV #GTSTXY,F + JSR PC,GTSXY2 ;SET X AND Y TO WHAT THEY ARE (!?!) + MOV DCURA,B ;LIKEWISE FOR ANGLE + JSR PC,GTSET1 ;SET HEADING + BIT #PENUF,DFLAGS ;IS THE PEN SUPPOSED TO BE UP? + BNE 9$ ;YUP + JSR PC,GTPD ;NO, PUT IT BACK DOWN +9$: SEZ + RTS PC + +RUBDIS: CMP #GTUDIS,GTLDF ;DISPLAY? + BNE 3$ + JSR PC,G1NARG + CMP B,GTLEN + BLE RUBDI1 +3$: ERROR+OOB +RUBDI1: MOV #GTRUB,F + NEG B + ADD B,GTLEN + DEC GTLEN ;SO THE RUBDIS ISN'T COUNTED + MOV PC,GTDIZY + TST GTNEW + BEQ 2$ + NEG B +2$: JMP GT11B1 + + + +.IFZ TVS!NDISP +;PENP +;RETURNS TRUE IF THE PEN IS DOWN +;RETURNS FALSE IF IT IS UP +PENP: JSR PC,GTTEST ;DOES HE OWN A DISPLAY OR PLOTTER? + BIT #PENUF,DFLAGS ;IS THE PEN UP? + BNE PENP1 ;YES + JMP RTTRUE ;NO, RETURN TRUE +PENP1: JMP RTFALS ;YES, RETURN FALSE + +WRAP: BIS #WRAPF,DFLAGS + SEZ + RTS PC + +NOWRAP: BIC #WRAPF,DFLAGS + SEZ + RTS PC +.ENDC +GTTEST: TST GTLDF + BNE 1$ + JSR F,ACSAV + JSR PC,GTLDI1 ;SET DISPLAY CODES ON, BUT NOT SMART RUBOUT + ;IF IT HAS BEEN TURNED OFF + JSR F,ACRES +1$: RTS PC + +GTTESD: JSR PC,GTTEST + TST GTDIZY ;IS THE TURTLE DIZZY? + BEQ 1$ + ERROR+TGD +1$: RTS PC + +.IIF NDF HERE,HERE: +GTHERE: JSR PC,GTTESD ;DOES HE OWN DISPLAY OR PLOTTER? + MOV #DCURX,F ;GET APPROPRIATE VARIABLES + JSR PC,WHOPIE ;PUT (F) INTO A NODE, POINTER IN B + PUSHS B ;STORE POINTER TO FNUMS ON STACK + JSR PC,WHOPIE ;DO IT AGAIN + PUSHS B + MOV (F),B ;PUT ANGLE (SNUM) IN B + JSR PC,PSHNUM ;PUT SNUM IN B ON S-PDL + MOV #3,D ;PUSH A FLAG ON + JMP SENT. ;CHANGE THE THREE THINGS INTO A SENTENCE + +.IIF NDF XCOR,XCOR: +GTXCOR: MOV #DCURX,F ;GET POINTER TO APPROPRIATE CURX + BR GTYCR1 ;GET NUMBER AND RETURN + +.IIF NDF YCOR,YCOR: +GTYCOR: MOV #DCURY,F ;GET APPROPRIATE POINTER TO CURX +GTYCR1: JSR PC,GTTESD ;DOES HE OWN A DISPLAY OR PLOTTER? + JSR PC,WHOPIE ;PUT NUMBER INTO A NODE,POINTER RETURNED IN B + JMP ORTB ;PUT POINTER IN B ON S-PDL + +.IIF NDF HEADIN,HEADIN: +GTHEAD: JSR PC,GTTEST ;DOES HE OWN A DISPLAY OR PLOTTER? + MOV #DCURA,F ;GET APPROPRIATE POINTER TO CURX + MOV (F),B ;MOVE CURA TO B + JMP R1NARG ;RETURN B + +.IFNZ LSI +;CALLED WITH THE AMOUNT OF A FORWARD IN B +;ONLY CALLED IF PLOTTER IS ACTIVE +PLOTTM: JSR PC,TIMCMP ;IS THE PREVIOUS COMMAND DONE? + BLO 1$ ;NO, JUST ADD + MOV LSTIME,PTIME + MOV LSTIME+2,PTIME+2 +1$: SAVE B + BGE 2$ + NEG B +2$: INC B ;FUDGE TO BE SURE + ADD B,PTIME ;TIEM FOR NEXT COMMAND COMPLETION + ADC PTIME+2 + REST B + RTS PC + +PWAIT: SAVE B + MOV #30.,B ;FUDGE FACTOR + JSR PC,PLOTTM + REST B +2$: TST BRAKE + BEQ 1$ + ERROR+BRK +1$: JSR PC,TIMCMP + BLO 2$ + RTS PC + +TIMCMP: CMP LSTIME+2,PTIME+2 ;COMPARE HIGH PARTS + BNE 1$ ;CONDITONS SET + CMP LSTIME,PTIME ;NOW SET +1$: RTS PC + +.ENDC ;lsi +.ENDC ;GTL diff --git a/src/nlogo/iggl.1 b/src/nlogo/iggl.1 new file mode 100755 index 00000000..23de4241 --- /dev/null +++ b/src/nlogo/iggl.1 @@ -0,0 +1,2 @@ +.MACRO .GLOBL +.ENDM diff --git a/src/nlogo/impure.77 b/src/nlogo/impure.77 new file mode 100755 index 00000000..391eabd6 --- /dev/null +++ b/src/nlogo/impure.77 @@ -0,0 +1,781 @@ + .SBTTL IMPURE STORAGE + VERSIO + +FOO=. +.IFNZ TS +.=34 + ERRBRK + .=40 +.IFF +.=0 + .REPT 60 + .+2 + BPT + .ENDR +.=40 + ERRBRK ;KLUDGE, TRAPS GO TROUGH USER 40 ON LSI +.=300 + JMP START ;MAGIC START/RESTART PLACE (300 + JMP START1 ;HERE IS WE WANT TO CLEAR THE WORLD (304) + MOV PC,IGNERR ;START HERE TO IGNORE PATCHES + BR 300 +.ENDC +.=FOO + +LVERNF: VERNF +PAT: +PATCH: .=.+400 ;PATCH AREA +PATEND=. + +.SBTTL LSI UTILITY FILES (VARIABLES) + +.IFNZ LSI + +;XOR TABLES FOR THE SYSTEM +XORFLG: 0 ;NON-ZERO => XOR S SHOULD BE CORRECT +SYSXOR: 0 ;XOR OF WHOLE SYSTEM +SYSTAB: .BLKW 16. ;XOR OF ADDRESS+2 FOR EACH BIT +WRNGBT: 0 ;SAVED WRONG BITS +WRNGAD: 0 ;SAVED WRONG ADDRESS +WRNGCN: 0 ;COUNT OF CORRECTED ERRORS +IGNERR: 0 ;TOO MANY ERRORS, IGNORE ALL +INCNT: 0 ;SAVED COUNT FOR INCREMENTAL CHECK +INADDR: 0 ;SAVED ADDRESS +INXOR: 0 ;SAVED XOR +.ENDC + .SBTTL USER VARIABLES +.IFZ SITS + IIS=LOGEND + IIP=IS-<2*SPDLL> +INITTB: ERTXTL + RERTXT +.IF Z RKDSK + 1024. ;BYTES IN A DISK BLOCK + LSDBAD +.ENDC + GCBTL + GCBITA ;THE BIT TABLE +.IF NZ LSMAP + 0 + LOWPAG +INITMP: ;STUFF ABOVE HERE GETS ALLOCATED IN HIGH MEMORY + ;IF WE HAVE A MAP +.ENDC + 0 + S + 0 + SPOPL + 0 + IS + PDSLOP/3 + SPOPLM + SPDLL+ ;TO SET LIMIT ON PDL + SPUSHL + <2*SPDLL>->> ;GET TO THE TOP OF THE P PDL + IP + 0 + PPOPL + PDSLOP/3 + POPLM + PPDLL+ + PPUSHL + <2*PPDLL>->> + PPDTOP +.IF NZ RKDSK + 1024. ;BYTES IN A DISK BLOCK + LSDBAD +.ENDC + +INITTE:: +.ENDC +SPMSWP: 0 ;THE PLACE WE ARE MARKING IN GHT ESWAPPED OUT PDL +PDLEMR: 0 ;PDL EMERGENCY FLAG +IS: IIS +S: IIS +SPOPL: IIS +SPUSHL: IIS-> +SPDLCP: 0 +SPEMR: 0 ;S PDL EMERGENCY FLAG +SPLIMT: 20000 ;LIMIT ON S PDL +SCRBLK: 0 +IP: IIP +PPOPL: IIP +PPUSHL: IIP-> +PPDLCP: 0 +PPEMR: 0 ;P PDL EMERGENCY FLAG +PPLIMT: 40000 ;LIMIT ON P PDL +PPDTOP: IIP-<2*PPDLL> ;DSK=0 PDL BUFFER TOP (BOTTOM) + .IFNZ FILDSK +DC NDISKS,4 +DC MXNAME,10. ;MAX LENGTH OF NAME IN WORDS +DNAME: .BLKW 5 ;BITS, LENGTH, DATE, TIME +DNAM: .BLKW MXNAME ;ACTUAL NAME +DNAMEP: .REPT NDISKS ;NDISKS IS MAX NUBMER OF DISKS WHEN PUT IN .EVAL + DNAMES+<.RPCNT*MXNAME*2> + .ENDR + 0 +DNAMES: .BLKW MXNAME*NDISKS +DISKS: NDISKS ;NUMBER OF DISKS +.IFTF +REDFLG: 0 +WRTFLG: 0 +.IF Z UNIX +NAME: .BLKW 10. +.IFF +NAME: .BLKW 200. +.FLDSC: .BLKW NCHNS + +.APEND: SYS OPEN + #NAME +.APMOD: 0 ;THIS IS FILLED IN FOR READ OR READ/WRITE + +.LSEEK: SYS LSEEK ;RESTORE FILE POSITION AFTER CHECKING EOF +.LSOF1: 0 ;ALSO USED FOR EXPLICIT USER SEEK +.LSOF2: 0 + 0 + +.FTIME: ;BUFFER FOR RESULTS OF TIME SYS CALL +.STIM1: 0 ;HIGH-ORDER PART OF TIME IN SECS +.STIM2: 0 ;LOW-ORDER DITTO +.MSTIM: 0 ;EXTRA TIME IN MILLISECS + 0 ;TIMEZONE + 0 ;DAYLIGHT SAVINGS FLAG + +.GTTY: 0 + 0 + 0 + +RDBYTE: 0 ;BUFFER FOR SINGLE-CHAR TRANSFERS +.ENDC +MAXPLN==40. +PATH: .BLKB MAXPLN +NPATH: .BLKB MAXPLN +DC FILRED,1 ;FLAG FOR READING +DC FILWRT,2 ;FLAG FOR WRITING +DC FILDIR,4 ;FLAG FOR DIRECTORY +DC FILNDK,10 ;FLAG FOR NON-DISK CHANNEL +FILFLG: .BLKW NCHNS ;THE ABOVE FLAGS ARE SET IN HERE +FILFLP: FILFLG ;POINTER TO FILE FLAG FOR THIS CHANNEL +CHAN: 0 ;NUMBER OF CHANNEL THIS COMMAND IS HACKING +.IFT +DIRFLG: 0 ;NONZERO <=> NOTHING LEFT TO .FILER FROM OPEN DIRECTORY +DIRIGN: 0 ;NUMBER OF CHARS TO IGNORE ON THIS PASS OF POIING +DIRIGC: 0 ;NUMBER OF CHARS TO IGNORE ON NEXT PASS +DIRIGP: 0 ;SAVED PDL POINTER FOR NON LOCAL RETURN +DIRCAP: TMPCP ;PTR TO TMPCP OR CURCAP FOR .POI +MWCOUT: 0 +MWCNT: 0 +MWTTY: 0 +MWFLAG: 0 +.IIF NZ LSI, BITS: .ASCIZ /BITS/ + .EVEN +DSKERW: 0 ;PALCE TO SAVE SITS ERROR WORD + +CURROT: 0 ;CURRENT ROOT +DEFROT: 0 ;DEFAULT ROOT +.IF NZ LSI +ROTCPS: .BLKW NDISKS ;CAPABILITYS TO ROOTS. 0=> WE DON'T HAVE ONE FOR THIS DISK +ROTBLK: 0 ;"BLOCK" FOR CREATING ROOT CAPS WITH +.ENDC +CURCAP: .BLKW NCHNS ;CURRENT FILE CAP +CURCPP: CURCAP ;POINTER TO REAL CURRENT CAP +CURCPE: FILERR ;ERROR ADDRESS TABLE +FILERR: .BLKW NCHNS +DEFCAP: 0 ;DEFAULT DIRECTORY CAP +DISCAP: 0 +FREEBL: 0 +DSKNUM: 0 +;FOLLOWING MUST BE IN ORDER, COPY OF ENTRY +ENTRY: 0 ;HEADER WORD +TVERN: 0 ;VERSION NUMBER +ENTEFH: 0 ;HIGH ORDER EOF WORD +ENTEOF: 0 ;LOW ORDER EOF WORD +DATE: 0 +TIME: 0 +ENNAME: .BLKW 10. ;NAME AND DESCRIPTOR +FILBLK==ENNAME ;ALSO USED FOR .FARI +MXENLN==.-ENTRY ;MAX ENTRY LENGTH IN BYTES +ENTEND: .BLKW 4 ;FOR VERSION NUMBER + -1 ;FENCEPOST +CAPSP: CAPSTK +CAPSTK: .BLKW 20. +TMPCP: 0 +;DISPATCH TABLE FOR POTREE (INDEXED OFF OF DISK ENTRY TYPES) +PODIRC: 0 ;CURRENT DIRECTORY BEING POTREE'D +DBUF: .BLKB DBUFL +DBUFP: 0 ;POINTER INTO THE DISK BUFFER +DBDEND: 0 ;POINTER TO ONE PAST THE LAST VALID DATA BYTE +BCHNG: 0 ;0 => BUFFER NOT MODIFIED, 1=> BUFFER MODIFIED +DBUFST: .BLKW 2 ;START OF THE BUFFER IN THE FILE +.ENDC +.IIF NZ ENG&FR,LANG: FRFLG!PFRFLG +PRMTCH: '? ;PROMPT CHAR +GTLBUF: .BYTE 33,0,0,0 +TYICP: 2 +TYOCP: 3 +RNSEED: 27. ;FOR RANDOM +MUCWRD: 100 ;CONTROL CHAR FOR CURRENT MUSIC BOX MODE +GCHR: 0 ;SOURCE OF CHARS +PCHR: 0 ;PLACE WHERE OUTPUT CHARS GO (TYO, BLST, ...) +OTTYST: 0 +TTYST: 0 +DFLAGS: .WORD 0 +DRIBF: SRTSPC ;ADDRESS OF DRIBBLE ROUTINE +.IFNZ CPF ;CENTRONICS PRINTER STUFF +DC CPSELC,21 ;SELECT CHAR +DC CPDSLC,23 ;DESELECT +.ENDC +.IF NZ TIMCLK +SSTATS:: ;THE SITS STATUS AREA +SVERN: 0 ;SITS VERSION +STIME: .BLKW 2 ;TIME SINCE SYS START IN 60THS +SCSR: 0 ;CONSLOE SWITCHS +LOOKSW: 0 +RANDS: .BLKW 10 ;POTENTIALLY THERE ARE MORE +SECOND: 0 +MINUTE: 0 +HOUR: 0 +DAY: 0 +MONTH: 0 +YEAR: 0 +.ENDC +.IIF NZ TIMCLK!FILDSK,GOTSMS: 0 ;IF NON-ZERO WE HAVE SMS FLOPPY CONTROLLER +.IIF NZ LSMAP,GOTMAP: 0 +.IF NZ METERS +METERP: MTTYI +DC MTZER,. ;PALCE TO START ZEROING METERS. ALSO METER ZERO +MTGCCN: .BLKW 2 ;GC COUNT +MTCLK: .BLKW 2 ;TIME SINCE METERS ZEROED +MTEVAL: .BLKW 2 ;TIME RANDOMLY IN EVAL (NOT IN PRIMITIVES, OR GC) +MTPRIM: .BLKW 2 ;TIME SPENT IN PRIMITIVES (BUT NOT IN LSITS OR GC) +MTGCOL: .BLKW 2 ;TIME SPENT IN GC +MTLSIT: .BLKW 2 ;TIME SPENT IN LSITS (NOT IN TYI OR DISK XFER) +MTTYI: .BLKW 2 ;TIME SPENT HANGING AROUND FOR TYPEIN +MTDISK: .BLKW 2 ;TIME SPENT DOING REAL DISK TRANSFERS +MTDSKC: .BLKW 2 ;COUNT OF DISK XFERS +MTSPR1: .BLKW 2 ;SPARE #1 +MTSPR2: .BLKW 2 ;SPARE #2 +MTFLAG: .BLKW 2 ;IF ZERO, RUN THE METERS +PCMETR: .BLKW 2*32. ;TIME SPENT AT PC, INDEX ON 5 HIGH BITS +DC MTZERE,. +.ENDC + ZEROS: ;BEGINNING OF STUFF THAT GETS ZEROED +;************** +;WARNING!!! ON RESTART, EVERYTHING ON THIS PAGE IS SET TO ZERO !!!! +;************** +PCRBLK: 0 +ERRPT: 0 +ERRPNT: 0 +PRBAO: 0 ; = 0,374,770, ... N*PDSWOP +SPRBAO: 0 ;WHERE N = # P OR S PDL BLOCKS SWAPPED OUT +PRB: 0 ;LIKE PRBAO, BUT NOTHING ACTUALLY SWAPPED OUT +SPRB: 0 ; PRB AND SPRB ARE USED WHEN DSK=0, IE NO DISK +NNGC: 0 ;NUMBER OF NODES GARBAGE COLLECTED +NNIFSL: 0 ;NO. NODES IN FREE STORAGE LIST +FREE: 0 ;START OF FREE NODES +GCP1: 0 +GCP2: 0 +GCPREV: 0 +;ARRAY HEADER DEFS +DC LIMIT,3 +DC HEADER,20. ;THIS INCLUDES EVERYTHING POSSIBLY IN A HEADER +DC RHEADR,HEADER-8. ;REAL HEADER IS THE ARRAY HEADER WITHOUT THE WINDOW STUFF +DC FHEADR,6 ;THIS IS ALL YOU NEED TO HAVE A FREE BLOCK +DC BKPTR,4 +DC SIZE,2 + +DC PROCAR,4 ;TYPE OF ARRAY FOR PROCEDURES +DC PROTYP,4 ;PLACE WHERE THE TYPE IS STORED +DC PROATM,6 ;PLACE WHERE THE POINTER TO THE PNAME OF THIS PROCEDURE +DC PROSTK,10 ;COUNT OF REFERENCES TO THIS PROCEDURE ON THE STACK +DC PROEND,12 ;OFFSET TO THE END OF THIS PROCEDURE FROM THE START OF THE ARRAY +DC PROSTR,14 ;THIS IS WHERE THE PROCEDURE ACTUALLY STARTS + +PARRYS: 0 ;POINTER TO START OF PROCEDURE ARRAY WE ARE EDITING +PARRYF: 0 ;NUMBER OF FREE BYTES IN THE PROCEDURE BEFORE WE NEED TO EXPAND + +;THE LENGTH OF USED PROCEDURE IS STORED IN THE FIRST DIMENSION OF THE ARRAY +DC PRSIZE,60. ;NUMBER OF BYTES TO ALLOW FOR INITIAL PROCEDURE ALLOCATION +DC PROINC,60. ;NUMBER OF BYTES TO ADD EVERY TIME WE ADD MORE CORE TO THE PROC + ;************** +;WARNING!!! ON RESTART, EVERYTHING ON THIS PAGE IS SET TO ZERO !!!! +;************** +;DOUBLE WARNING!!!!! ON ERRORS, EVERYTHING ON THIS PAGE GETS SET TO ZEROS +;**************** + DC ERCLR1,. ;ON ERROR, START ZEROING HERE +OLFUN: 0 ;USED FOR REDEFINING SYS. FUN +TOPS: 0 ;GC MARK FROM HERE IF NON 0 +TOPS1: 0 ; " +TOPS2: 0 ; " (SIGH) + ;THE FOLLOWING ARE PUSHED BY PEVAL +CPBND: 0 ;POINTER TO THE CURRENT PROCEDURE'S BINDING NODE + ;SEARCH FOR THE LINE) +CTP: 0 ;POINTER TO THE NEXT TOKEN +CLCNT: 0 ;NUMBER OF TOKENS LEFT ON THIS LINE +CPLN: 0 ;CURRENT LINE NUMBER +CPP: 0 ;POINTER TO THE CURRENT PROCEDURE NAME +IFLEV: 0 ;IF LEVEL +NOPAR: 0 ;NUMBER OF PARENS SEEN BY STNE +CPDLP: 0 ;CURRENT PDL PTR AFTER LAST PEVAL PUSH +CSPDLP: 0 ;CURRENT S PDL PTR AFTER LAST PEVAL PUSH + ;END OF PEVAL PUSHES EXCEPT + ;CO, CO+2, FLAGS + ERPROC ARE ALSO PUSHED +FUNLEV: 0 ;FUNCTION LEVEL + ;THE FOLLOWING ARE PUSHED (SOMETIMES) BY EVAL +CO: 0 ;CURRENT OPERATOR +NOR: 0 ;NO. OF OPERANDS STILL NEEDED BEFORE CO CAN EXECUTE +COF: 0 ;FLAGS FOR THE CURRENT OPERATOR +LO: 0 ;LAST OPERATOR +CT: 0 ;CURRENT TOKEN +RDFLAG: 0 ;FOR READ +LISTBD: 0 ;LIST BUILD DEPTH +PSTOPR: 0 ;RETURN ADDR FOR PSTOP +DOFRET: 0 +TEMP: 0 +TMPBLK: .BLKW 7 +.IFNZ SARITH +;THIS IS THE MAXIMUM LENGTH OF STRING NUMBERS ALLOWED (MUST BE EVEN) +DC MXNUML,24. + +NUM1: .BLKB MXNUML+2 +NUM1EN==. +NUM2: .BLKB MXNUML+2 +NUM2EN==. +NUM3: .BLKB MXNUML+2 +NUM3EN==. +NUM1E: 0 ;POINTER TO THE END OF NUMBER 1 +NUM2E: 0 ;SIMILAR FOR NUMBER 2 +NUM3E: 0 ;SIMILAR FOR NUMBER 3 +NUM1S: 0 ;NEGATIVE FLAG OF NUMBER 1 +NUM2S: 0 ;SIMILAR FOR NUMBER 2 +NUM3S: 0 ;SIMILAR FOR NUMBER 3 +.ENDC +RBRKF: 0 ;TEMP FLAGS (ALL TFN'S SHOULD EVENTALLY POINT HERE) +TF3: 0 +TF5: 0 +TF6: 0 +TF7: 0 +NCHR: 0 ;FOR BLST +ABASE: 0 ;(ABASE)+10. IS WHAT ARITHMETIC BASE WE ARE IN + ;(FOR CONVERT TO & FROM STRING ROUTINES) + DC ERCLR2,. ; ON ERROR STOP CLEARING HERE + ;************** +;WARNING!!! ON RESTART, EVERYTHING ON THIS PAGE IS SET TO ZERO !!!! +;************** + +FLAGS: 0 ;FLAG WORD +EDTIF2: 0 ;TEMP EDIT FLAG +ERPROC: 0 ;UOE PTR TO PROC TO CALL IF THERE IS AN ERROR +ILINEL: 0 ;INPUT LINE PTR GC MARK FROM HERE) +NPROCL: 0 ;NAME OF PROC BEING EXECUTED WHEN ERROR OCCURED +NLINEL: 0 ;# OF PROC LINE BEING EXECUTED " " " +NTOKEL: 0 ;# OF TOKEN BEING EXECUTED " " " +ERRORN: -1 ;ERROR NUMBER +BRAKEL: 0 ;VALUE OF BRAKE(U) +BRAKE: 0 +TOPRNM: 0 ;PTR TO UOE OF PROC. BEING "TO"'ED +FLAGS2: 0 ;EVAL FLAGS - NOT PUSHED BY PEVAL +GNCN: 0 ;"GET NEXT CHAR" NODE AND USED BY GNOLE + 0 +NBKTS: 0 ;FOR RDSTR +LASTER: 0 ;ADDRESS OF LAST ERROR +LASTPR: 0 ;LAST PROC DEFINED +PTBF: 0 +PTBTAB: .BLKW 4 +ALEVN: 0 ;NON-ZERO MEANS ALLOW N LEVEL BREAK STUFF +ENDWLD: 0 +SEXP: 0 ;USED FOR SIGN OF EXPONENT IN CONVERT +FNPDL: 0 ;AUXILIARY STACK IN CONVERT + 0 + 0 + 0 + 0 + 0 + 0 + 0 + +;************** +;WARNING!!! ON RESTART, EVERYTHING ON THIS PAGE IS SET TO ZERO !!!! +;************** +.IF NZ MUSBOX + DC MUSBEG,. + ;KEEP VARIABLES IN THIS ORDER +MVOC: .WORD 0,0,0,0 ;POINTERS TO VOICE LISTS--ONE FOR EACH VOICE +VLAST: .WORD 0,0,0,0 ;POINTERS TO LAST NODE IN LIST +VOICLN: .WORD 0,0,0,0 ;NUMBER OF NOTES IN EACH VOICE +VOICEN: 0 ;INDEX FOR CURRENT ACTIVE VOICE +NVOIC: 0 ;NUMBER OF ACTIVE VOICES + DC MUSEND,. +.ENDC +.IF NZ NPLOT +PLTCHR: 0 ;CHAR COMING BACK FROM PLOTTER + +DPENP: .WORD 0 +PLPENP: .WORD 0 +;PLOTTER VARIABLES +;THESE MUST BE IN ORDER +DC PORBEG,. +PCURX: .WORD 0,0 ;CURRENT PLOTTER X POS +PCURY: .WORD 0,0 ;PLOTTER CURRENT Y +PCURA: .WORD 0,0 ;CURRENT ANGLE PLOTTER +PCOSA: .WORD 0,0 +PSINA: .WORD 0,0 +RPCURX: .WORD 0,0,0,0 +DC POREND,. +.ENDC +.IF NZ TURFLG +;VARIABLES AND CONSTANTS FOR DISPLAY SYSTEM + +;TURTLE VARIABLES +TURDN: 0 ;USER'S TURTLE DEVICE NUMBER +TURF: 0 ;FUDGE FACTOR FOR TURTLE LEFT AMD RIGHT + +DIVOWN: .WORD 0 +.ENDC + +.IF NZ GTL!NDISP + +;THESE MUST BE IN THIS ORDER +DC DORBEG,. +DCURX: .WORD 0,0 +DCURY: .WORD 0,0 +DCURA: .WORD 0,0 +DCOSA: .WORD 0,0 +DSINA: .WORD 0,0 +RDCURX: .WORD 0,0,0,0 +OLDX: .WORD 0,0 +OLDY: .WORD 0,0 +.IF NZ NDISP +NADXY: 0 ;NUMBER OF EXTRA ADDXY'S WE CAN TRY TO COLLAPSE +ODIREC: 0 ;IF NOT EQUAL TO DIREC BREAK INCREMENTS TO NEW OWRD +.ENDC +DC DOREND,. ;MARKS END OF THESE VARIABLES +;END OF ORDER +.IF NZ GTL +DC GTSTRT,170 ;FIRST ADDRESS IN 2500 FOR DISPLAY AREA +DC GTMNDS,1800. ;MINIMUM SPACE ALWAYS RESERVED FOR ACTIVE DISPLAY + ;GTSNBT CAN NEVER BE LOWER THAN THIS + ;THIS ALSO HAPPENS TO BE THE MAX LENGTH IN THE NEW CODE +DC GTDEND,5700 ;LAST ADDRESS +DC GTNEND,2000 ;LAST SNAP ADDRESS, NEW CODE +DC GTSLEN,GTDEND-GTSTRT ;LENGTH OF DISPLAY AREA +DC GTDTOP,64. ;# OF DLIST POINTERS AVAILABLE +GTDPTR: 0 ;NEXT DLIST POINTER INDEX +GTLDF: 0 ;says if the 2500 is active +GTNEW: 0 ;NON-ZERO => NEW 2500 +GTLEN: 0 ;LENGTH OF CURRENT THING BEING DISPLAYED +GTSNBT: 0 ;BOTTOM OF SNAP SPACE (RELATIVE TO START=GTSTRT) +GTSNTP: 0 ;TOP OF SNAP SPACE +GTDIZF: 0 ;IF NON-ZERO, NEVER CLEAR DIZZY FLAG +GTDIZY: 0 ;IF NON-ZERO TURTLE IS DIZZY (SPIN OR MOVE) +GTDLTP: 0 ;TOP OF DISPLAY LIST +.IFNZ LSI ;ONLY IMPLEMENTED FOR THE LSI AT THE MOMENT +PTIME: 0,0 ;THE TIEM WHEN THE PLOTTER WILL HAVE SETTLED +.ENDC +.ENDC +.IF NZ NDISP +STB: 0 ;STATIC AREA BOTTOM +STT: 0 ;STATIC AREA TOP.POINTS TO TOP OF STATIC DISPLAY AREA +DYB: 0 ;DYNAMIC BOTTOM. POINTS TO BOT OF DY AREA +DYR: 0 ;ROVING POINTER USED BY DISPLAY STORAGE ALLOCATIN ROUTINES +DYT: 0 ;POINTER TO DYNAMIC AREA TOP +TUB: 0 ;POINTER TO TURTLE AREA BOTTOM +SNLIST: 0 ;POINTER TO SNAP LIST +SNABOT: 0 ;BOTTOM OF CURRENT SNAP +DFBCNT: 0 ;KEEPS TRACK OF # OF FREE BITS IN DISPLAY LIST +PUSHJT: 0 ;DISPLAY PUSHJ TO TURTLE +DRELOC: 0 ;RELOCATION. ADD THIS TO VIRTUAL ADDRESS TO GET DISPLAY ADDRESS +DIREC: 0 +.ENDC +.ENDC +EZEROS:: ;END OF ZEROING + +.IIF NZ HALFLG, .INSRT HALVAR > + +.IFNZ TVS +;VARIABLES FOR TV TURTLE ROUTINES + +WINDAT: -1. ;Data to be written in TVRWIN register. 0 for B&W eraser mode, else -1. +TVX: 423. +TVY: 152. ;POSITION OF THE TV DRAWER +TVTOP: 2. ;TOP LINE OF THE DISPLAY AREA +TVBOT: 302. ;BOTTOM LINE OF THE DISPLAY AREA +TVLEFT: 273. ;BIT POSITION OF LEFT SIDE OF DISPLAY AREA +TVRIGH: 573. ;BIT POSITION OF RIGHT SIDE OF DISPLAY AREA +TVSIZX: 301. ;SIZE OF DISPLAY AREA IN X DIRECTION +TVSIZY: 301. ;SIZE OF DISPLAY AREA IN Y DIRECTION +TVCENX: 423. ;BIT POSITION OF CENTER OF DISPLAY AREA +TVCENY: 152. ;LINE OF THE CENTER OF DISPLAY AREA +TVMIN: 301. ;MINIMUM DIMENSION OF DISPLAY AREA +TVSIZE: 0 ;NUMBER OF LINES IN DISPLAY AREA (DOWN TO ECHO AREA) +TVHIGH: 0 ;HEIGHT OF A CHAR LINE IN TV LINES +TVWIDE: 0 ;WIDTH OF A CHAR IN BITS + +;THE NEXT SET OF VARIABLES REFER TO THE TURTLE PICTURE. IE, THE SCREEN +;AS MEASURED IN TURTLE COORDINATES. +TRMIN: 400. ;MINIMUM DIMENSION OF DISPLAY AREA +TRCENX: 0 ;CENTER OF TURTLE SCREEN IN X +TRCENY: 0 ;CENTER OF TURTLE SCREEN IN Y + +;FLOATING POINT VARIABLES +TRPRTV: .WORD 0,0 ;NUMBER OF TURTLE INCREMENTS PER TV INCREMENT +TRFRAD: .WORD 0,0 ;SIZE OF THE TURTLE FRONT RADIUS +TRSRAD: .WORD 0,0 ;SIZE OF THE TURTLE SIDE RADIUS +TRSIZX: .WORD 0,0 ;SIZE OF TURTLE SCREEN IN X +TRSIZY: .WORD 0,0 ;SIZE OF TURTLE SCREEN IN Y +TRRIGH: .WORD 0,0 ;TURTLE VALUE OF RIGHT BORDER +TRLEFT: .WORD 0,0 ;TURTLE VALUE OF LEFT BORDER +TRTOP: .WORD 0,0 ;TURTLE VALUE OF BOTTOM BORDER +TRBOT: .WORD 0,0 ;TURTLE VALUE OF BOTTOM BORDER +TRSCLX: .WORD 0,0 ;X TURTLE SCALE FACTOR +TRSCLY: .WORD 0,0 ;Y TURTLE SCALE FACTOR + + + ;Definitions of registers relevant to color stuff. + +DISOFF == 164100 - DISAD ;Offset of display addresses. + +COLORD == 164102 - DISOFF ;Color data +VIDSW == 164104 - DISOFF ;Video switch +COLORA == 164106 - DISOFF ;Color address + +CLRRED == 300 ;IOR these with color map address into COLORA to set +CLRGREEN == 500 ;red, green, blue intensities. +CLRBLUE == 600 + +TVINCR == 164140 - DISOFF ;The increment register for the TV's +TVINC == 77 ;The mask for the increment +TVRSET == 100000 ;The reset bit +TVCLRW == 400 ;The color write bit +TVOFLO == 1000 ;Mask to handle overflow in increment register + +TVSEL == 164142 - DISOFF ;The console select register +TVRCNS == 77 ;The console number mask +TVRWMD == 300 ;The regular write mode mask +TVNSH == 0 ;No shift write mode +TVIOR == 100 ;The inclusive or mode +TVXOR == 200 ;The XOR mode +TVSET == 300 ;The set mode [word moved directly to destination] +TVDCNS == TVRCNS * 400 ;The disk console number (same, but in top byte) +TVDWMD == TVRWMD * 400 ;The disk write mode mask + +TVRADR == 164144 - DISOFF ;The regular address register + +TVWDCN == 164146 - DISOFF ;The word count for the block write +TVWDCM == 777 ;Mask for word count +TVDADR == 164150 - DISOFF ;The disk transfer address register + +TVSHR == 164152 - DISOFF ;The shift register +TVSHCN == 17 ;The shift count +TVMAP == 17400 ;The start of the 16k page (in 4k blocks) +TVAMAP == 20000 ;The activate tvmap bit + +TVMSK == 164154 - DISOFF ;The mask register + +TVDWIN == 164156 - DISOFF ;The window for disk transfers + +TVRWIN == 164160 - DISOFF ;The window for regular transfers + +TVCNSO == 164162 - DISOFF ;The console register for the memory +TVCLR == 160000 ;The color number + + +;Magic constants + +VSWMC1 == 30_10 + 0 ;Video switch magic constant 1 +VSWMC2 == 31_10 + 1 ;Video switch magic constant 2 +VSWMC3 == 32_10 + 2 ;Video switch magic constant 3 +VSWMC4 == 33_10 + 3 ;Video switch magic constant 4 +CRMC1 == 1_15 ;Console register magic constant 1 +CRMC2 == 2_15 ;Console register magic constant 2 +CRMC3 == 3_15 ;Console register magic constant 3 +CRMC4 == 4_15 ;Console register magic constant 4 +ROTMC == 35400 ;Rotate register magic constant +WORLIN == 36. ;Number of 16 bit words on a TV line [576 bits] +BYTLIN == 72. ;Number of 8 bit bytes on a TV line. +TVXSMN == 20. ;TV X size minimum [args to TVSIZE]. +TVXSMX == 570. ;TV X size maximum. +TVYSMN == 20. ;TV Y size minimum. +TVYSMX == 415. ;TV Y size maximum. +PIXMAX == 4. ;Maximum number of bits per pixel. +PALMAX == 1_PIXMAX ;Maximum palette size. + + +;End of color TV register definitions. + + +;Variables for color TVs. + +PENNUM: 0. ;Pen number in palette [:PENNUMBER in Lisp] +ERANUM: PALMAX-1 ;Index of eraser in palette [:ERASERNUMBER] +NCBITS: PIXMAX ;Number of bits per point in color. +PALSIZ: PALMAX ;Size of the palette. +NCSIGB: 1_ ;High order color bit, used by RTVPN. + +DSCAP: .BLKW PIXMAX ;Table of capabilities to screen buffers. +DSNUM: .BLKW PIXMAX ;Table of buffer numbers associated with buffers in DSCAP. + +;The Palette is a set of locations holding atomic symbols of colors. +;This must be marked by the garbage collector. +;The palette is initially filled with NIL [list type code, zero pointer]. + +PALETTE: + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST + LIST +PALEND: + +;For debugging purposes a set of locations which can be used +;to look at the corresponding TV registers, since you can't look +;at them directly as DDT will show you the registers for its process, +;not Logo's. + +FAKCLD: 0 ;Fake COLORD +FAKCLA: 0 ;Fake COLORA +FAKINC: 0 ;Fake TVINCR +FAKSEL: 0 ;Fake TVSEL +FAKADR: 0 ;Fake TVRADR +FAKWDC: 0 ;Fake TVWDCN +FAKSHR: 0 ;Fake TVSHR +FAKMSK: 0 ;Fake TVMSK +FAKWIN: 0 ;Fake TVRWIN +FAKCNS: 0 ;Fake TCNSO + + +;TEMPORARY LOCATION USED BY FACSAV +FACTMP: .WORD 0,0 +.ENDC +.IFNZ TS +DC TTYHGH,66 ;NUMBER OF TTYS +TTYCPS: ;CAPS OF THE TTYS, 0 IF NOT OPEN + .BLKB TTYHGH +.EVEN +.IFF +.IF G LSTTY-1 +DC TTYHGH,LSTTY +TTYCPS: .BLKB TTYHGH +.EVEN +.ENDC +.ENDC + + .=.+40 ;FOR THE BREAK PROCESS +BRKPDL:: + .=.+20 ;FOR RESTARTING +RSTPDL:: +;RESTART PDL MUST BE BEFORE REGULAR PDL +.IFNZ DSK + .=.+PPDLL+PDSLOP + IIP=. +.=.+4 +DC SSWPAD,IIS-PDSWOP + .=.+SPDLL+PDSLOP + IIS=. +.=.+4 +DC PSWPAD,IIP-PDSWOP +.ENDC +POPLM: IIP- +SPOPLM: IIS- +DC HCC,67. ;HASH CODE CONSTANT - A PRIME +UHCT: .=UHCT+<2*HCC> + -1 + +DC NNODES,4096. +DC GCBTL, NNODES/8./2.*2. ;GARBAGE COLLECT BIT TABLE LENGTH + +.IF Z LSI +GCBITT: .BLKB GCBTL +.ENDC +DC INLEN,100. ;NUMBER OF TOKENS PERMITTED IN THE INPUT STREAM +CURPNT: CURLIN ;FAKE BINDING NODE FOR THE CURRENT LINE +CURLIN: .BLKW INLEN+3+
;LENGTH + LINE NUMBER, GENERATION NUMBER, AND ONE FOR SAFETY + HEADER FOR FAKE PROCEDURE +PBASE: 0 ;POINTER TO THE BINDING NODE FOR THE PROCEDURE + ;BEING TEXTIFIED OR PRINTED OUT + +RAN: 0 ;IF NON-ZERO, THIS LOGO HAS BEEN STARTED BEFORE +MAINPR: 0 ;CAP TO MAIN PROCESS, FOR BREAK +DEBSW: 1- ;DEBUG SWITCH, NON-ZERO IF BEING DEBUGGED +NOADDR: 1 ;ZERO MEANS PRINT ADDRESS OF ERRORS +ASIZE: 0 ;SIZE OF ARRAY SPACE (SHOULD BE ZERO) + +.IF Z LSI +GCBITS: GCBITT +.IFF +LSDBAD: 0 ;LSI DISK BUFFER ADDRESS +GCBITA: 0 ;EITHER REAL ADDRESS OR PAGE ADDRESS +GCBITS: 0 ;ADDRESS OF GC BIT TABLE +RERTXT: 0 ;REAL ADDRESS OF ERROR TEXT +.IF NZ LSMAP +HGHPAG: 0 ;HIGHEST EXISTING PAGE +LOWPAG: 0 ;LOWEST USED PAGE +.ENDC +.ENDC + .IFNZ NDISP +;DISPLAY SYSTEM VARIABLES +DC DPDLL,60 ;LENGTH OF EACH DISPLAY PDL (IN BYTES) +DC TLEN,20 ;LENGTH OF EACH TURTLE LIST (IN BYTES) +DC TLIST,DISAD +DC DLIST,TLIST+TLEN + .ENDC +TUT: 0 ;TURTLE TOP. POINTS TO TOP OF TURTLE DISPLAY LIST +SNPTEM: 0 ;USED BY GARBAGE COLLECTOR + + + DC CONSO,20 + DC PLOTT,40 + DC PMBOX,100 + DC INITF,1000 ;MUSIC BOX INITIALIZED + DC TURT,200 + DC TBMASK,177417 + dc tabdev,173774 + +TEM0: 0 +TEM1: 0 +ANSWER: .WORD 0,0 ;USED BY DOUBLE PRECISION ROUTINES +SHFCNT: 0 ;USED BY DOUBLE PRECISION ROUTINES +EXCH1: 0 + +INITED: 0 ;IF NON-ZERO INIT CODE HAS BEEN RUN +ZERO: 0 +AFREE: 0 ;POINTER TO ARAY SPACE FREE LIST +AROVER: 0 ;BOW-WOW +ASPACE: 0 ;AMOUNT OF ARAY SPACE STILL FREE +.IFNZ LSI!NOISPACE +MEMTOP: 160000 ;FIRST NON-EX LOCATION +RMEMT: 0 ;REAL TOP FOR CHAINING +NODTOP: ;IN LSI STORAGE ALLOC, TOP OF NODESP IS BOTTOM OF ARSPACE +ARYAD: NODESP+2000 +ARTOP: NODESP+2000 +.ENDC +.IF NZ SITS +ARTOP: ARYAD +HALLIM: 10000 ;NEVER ALLOW TOTAL IMPURE SPACE TO BE ABOVE THIS +HALLLM: 10000+1+LSUPBL ;HALLLM-HALLIM IS THE AMMOUNT OF SPACE ALLREADY ALLOCATED +.ENDC +;KEEP THE NEXT 3 IN ORDER!!!! +ARRHPG: ARYPG-1 ;HIGHEST PAGE GOBBLED SO FAR +ARRHPL: 7 ;LENGTH OF HIGHEST PAGE +ARRHP: ARYHPG ;HIGEST PAGE TO EVER GOBBLE + +.IIF NZ SITS, NODTOP: NODESP+2000 +;KEEP NEXT 3 IN ORDER!!! +NODEHP: NODPG ;HIGEST NODE PAGE SO FAR + 0 ;LENGTH THEREOF + NODPG+1 ;HIGHEST PAGE TO GRAB +DC SYSHTL,16. ;IF YOU CHANGE THIS YOU ALSO HAVE TO CHANGE THE MASKS IN THE CODE +;END OF VARIABLES +.IIF GT .-PURAD,.ERROR OOOOPS! TOO MUCH IMPURE STUFF +DC LSUPBL,./2000 +.IIF NZ SITS,.=PURAD diff --git a/src/nlogo/init.56 b/src/nlogo/init.56 new file mode 100755 index 00000000..cb0dcd59 --- /dev/null +++ b/src/nlogo/init.56 @@ -0,0 +1,351 @@ +.SBTTL CONDITIONALIZER +VERSIO + +.IF NDF PASS2 + + .IIF NDF CPF, DC CPF,0 + .IIF NDF DMPCAS, DC DMPCAS,0 + .IIF NDF HALFLG, DC HALFLG,0 + .IIF NDF METERS, DC METERS,0 + .IIF NDF NOISPACE, DC NOISPACE,0 + + ;LANGUAGE CONDITIONALS, DEFUALT IS JUST ANGLAIS + .IIF NDF ENG, DC ENG,1 + .IIF NDF FR, DC FR,0 + .IIF NDF ARABIC, DC ARABIC,0 + .IIF NDF SWAHLI, DC SWAHLI,0 + .IIF NDF GERMAN, DC GERMAN,0 +.ENDC + +;SET VARIOUS FLAGS DEPENDING ON LSI, SITS OR UNIX +.IF NDF PASS2 + .IF NZ SITS + DC TS,1 + DC DSK,1 + DC TVS,1 + DC COLOR,1 + DC NPLOT,1 + DC NDISP,1 + DC DDF,1 + .IIF NDF LSIHAK, DC LSIHAK,0 + DC MUSBOX,1 + DC MAILER,1 + DC LSFLEM,0 + .IIF NDF FILDSK, DC FILDSK,1 + .IIF NDF TURFLG, DC TURFLG,1 + .IIF NDF PTBOX, DC PTBOX,1 + .IIF NDF LPF, DC LPF,1 + .IIF NDF TIMCLK, DC TIMCLK,1 + + DC LSPRNT,0 + DC LSMAP,0 + + .ENDC + + .IF NZ LSI + DC TS,0 + DC DSK,0 + DC TVS,0 + DC COLOR,0 + DC NPLOT,0 + DC NDISP,0 + DC DDF,0 + .IIF NDF LSIHAK, DC LSIHAK,0 + DC MUSBOX,0 + DC MAILER,0 + DC LSFLEM,0 + + .IIF NDF FILDSK, DC FILDSK,0 + .IIF NDF TURFLG, DC TURFLG,0 + .IIF NDF PTBOX, DC PTBOX,0 + .IIF NDF LPF, DC LPF,CPF + .IIF NDF TIMCLK, DC TIMCLK,0 + + .IIF NDF LSTTY, DC LSTTY,1 + DC LSDISK,FILDSK + DC LSCLK,TIMCLK + DC LSPRNT,LPF + DC LSNDB,0 ;DEFINIGN THIS TURNS OFF LSITS ALLOCATING DISK BUFFERS + DC LSMAP,1 + .ENDC + + .IF NZ UNIX + DC TS,1 + DC DSK,0 + DC TVS,0 + DC COLOR,0 + DC NPLOT,0 + DC NDISP,0 + DC DDF,0 + .IIF NDF LSIHAK, DC LSIHAK,0 + DC MUSBOX,0 + DC MAILER,0 + DC LSFLEM,1 + DC LPF,0 + + .IIF NDF FILDSK, DC FILDSK,1 + .IIF NDF TURFLG, DC TURFLG,0 + .IIF NDF PTBOX, DC PTBOX,0 + .IIF NDF TIMCLK, DC TIMCLK,0 + + DC LSPRNT,0 + DC LSTTY,0 + DC LSMAP,0 + DC RKDSK,0 + .ENDC + + .IIF NDF GTL, DC GTL,1 ;2500 DISPLAY (EVERYBODY SHOULD HAVE ONE!) + .IIF NDF DEBUGR, DC DEBUGR,SITS ;FOR THE MOMENT DEFAULT IS ON FOR SITS, OFF FOR LSI +.IF NDF MULTTY +MULTTY==0 +.IF NZ SITS +MULTTY==1 +.IFF +.IIF G LSTTY-1,MULTTY==1 +.ENDC + +.iif ndf rxdisk, dc rxdisk,0 +.ENDC + + ;RELATIVLY USELESS STUFF + DC FPPF,1 + DC NCHNS,20 ;NUMBER OF DISK CHANNELS + DC DPM1,1 ;SEE DAN MIRANKER + .IIF NDF AI, DC AI,1 + .IIF NDF NOERTX, DC NOERTX,0 ;USUALLY HAVE ERROR TEXT + .IIF NDF BOTUR, DC BOTUR,0 + .IIF NDF SARITH, DC SARITH,1 ;STRING NUMBERS USUALLY ALLOWED +.ENDC + + ;DATA SPACE PAGE MAP + +;PAGE 0 +; SYSTEM TRAP VECTOR(S) +; MISC VARIABLES +; BEGINING OF ARRAY SPACE + +DC PURPG,1 +DC PURAD,PURPG*20000 +DC PURE,PURAD +;PAGE 1 +; PURE CONSTANTS +; MISC +; SOBLST +; ERRORS+ERROR TABLES + +DC ARYPG,2 +.IIF NZ SITS, DC ARYAD,ARYPG*20000 +;PAGE 2 +; MORE ARRAYS + +;PAGE 3 +;MORE ARRAYS + +DC ARYHPG,4 +;PAGE 4 +; STILL MORE ARRAYS +; (END OF ARRAYS, CURRENTLY) + +DC DISPG,5 +DC DISAD,DISPG*20000 +;PAGE 5 +; OLD STYLE DISPLAY +; CONTROL REGISTERS OF TV DISPLAY +; MAYBE (UGH!) MORE ARRAYS + + +DC NODPG,6 +.IIF NZ SITS, DC NODESP,NODPG*20000 +.IIF NZ LSI!NOISPACE, DC NODESP,STORAG +;PAGE 6 +; START OF NODE SPACE + +DC NODPG1,7 +;PAGE 7 +; END OF NODE SPACE + + +DC SYPDLL,240 +DC DSECLN,400 +.IFZ LSI!NOISPACE +DC PPDLL,2000 +DC SPDLL,2000 +.IFF +DC PPDLL,1000 +DC SPDLL,1000 +.ENDC +DC PDSLOP,300. ;MUST BE EVEN AFTER DIVISION BY 3 +DC PDSWOP,2000 +DC MAXARG,32. +DC DBUFL,1000 + + +DC FRTRCF,1 +DC SWTRCF,2 +DC SPTRCF,4 +DC GCTRCF,10 + + ;NODE TYPES +DC SFUN,000000 +DC INFIX,10000 +DC UFUN,20000 +DC UVAR,30000 +DC IDLE,40000 +DC BUKTEL,60000 ;NODE IN BUCKET OF OBLIST (INVALID TOKEN TYPE) +;THE FOLLOWING TYPES ARE NEEDED IN THIS ORDER BY THE CONVERT ROUTINES +DC SSTR,70000 ;NOT VALID TOKEN TYPE +DC SNP,100000 +DC ATOM,110000 +DC SNUM,120000 ;NOT A VALID TOKEN TYPE +DC LNUM,130000 +DC INUM,LNUM ;INTEGER NUMBER +DC LSTR,140000 +DC FNUM,150000 +DC LIST,170000 +DC SENT,LIST +;END OF ORDER + + ;BINDING TYPES +DC FBIND,20000 +DC VBIND,30000 +;DON'T USE 40000, IT IS "IDLE" (UGH) +DC ABIND,50000 +DC SVBIND,130000 ;SWAPPED OUT VARIABLE BINDING +DC DBIND,60000 ;DELETED PROCEDURE BINDING + + + ;READ FLAGS SEE DTBL: +DC DOTF,400 ;IN LEFT HALF + ;EVAL FLAGS - PUSHED BY PEVAL +DC PTLPF,1 ;PREVIOUS TOKEN WAS LEFT PAREN +DC RTF,2 ;REPEAT TOKEN +DC CRF,4 ;CURRENT TOKEN IS CR +;DC EDITF,10 ;EDIT FLAG (no longer used) +DC DORF,20 ;SET IF THIS FRAME IS A DO OR A READ +DC CATCHF,40 ;SET IF THIS IS A CATCH FRAME... +DC TSTFLG,100 ;TEST FLAG FOR TEST, IFTRUE AND IFFALSE +DC SPDF,200 ;SKIP PROC DEF. FLAG +DC TPTF,400 ;THIS PROCEDURE TRACED FLAG ;MUST BE IN LEFT HALF +DC EDTIF,1000 ;EDIT TITLE FLAG +DC BRKF,2000 ;BREAK MODE FLAG +DC ERRF,4000 ;ERROR FLAG +DC TPSF,20000 ;THIS PROCEDURE STEPPED FLAG ;MUST BE IN LEFT HALF +DC TPBF,40000 ;THIS PROCEDURE BURIED FLAG ; " " " " " +DC EVIFS,PTLPF+RTF+CRF ;FLAGS CLEARED BY EVLINE + + ;EVAL FLAGS2 - NOT PUSHED +DC CPTBF,1 ;CHANGE % TO BLANK +DC TRACEF,2 +DC PQF,4 ;PRINT QUOTE FLAG - FOR PRSTR +DC DPQF,10 ;DONT " " " +DC SSF,40 ;SPECIAL STATUS FLAG +DC PADERF,100 ;PRINT ADDRESS OF ERROR +DC MGCF,200 ;MANY G. C.'S FLAG +DC PNNLF,400 ;PRINT NO. NODES LEFT +DC DSAMFL,1000 ;DISK ALMOST FULL +DC PPNAIF,2000 ;P PDL NOT ALL THE WAY IN +DC SPNAIF,4000 ;S PDL NOT ALL THE WAY IN +DC HERRF,10000 ;HARD ERROR +DC CHEKUF,20000 ;TURNS ON VARIOUS USER CHECKING THINGS + + + +DC NBN,40 ;# BUFFER NODES - IF FREE NODES < THIS, DC , NO STG LEFT + + + .IFNZ NDISP +;DISPLAY COMMANDS +DC ADDX,150000 +DC ADDY,144000 +DC ADDXY,ADDX!ADDY +DC DPUSHJ,100000 +DC DPOP,140200 +DC DPOPJ,140100 +DC DSTOP,140400 +DC DRSTXY,143000 ;RESET X AND Y TO 0 +DC DINC,40000 + +DC TURSIZ,6 ;THE SIZE OF THE TURTLE + +DC TKRUN,4000 +DC TKGO,10000 +DC TKSTOP,20000 +.ENDC + +.IFNZ GTL +DC GTNOP,0 ;NOP +DC GTHOME,4000 ;HOME +DC GTPEND,4400 ;PENDOWN +DC GTPENU,4407 ;PENUP +DC GTSTUR,5001 ;SHOWTURTLE +DC GTHTUR,5000 ;HIDETURTLE +DC GTSNAP,5400 ;SNAP (ADDRESS IN NEXT WORD) +DC GTBLNK,6000 ;BLINK +DC GTWRAP,6400 ;WRAP +DC GTRSET,7000 ;RESET??? +DC GTFD,10000 ;FORWARD+11 BITS OF DISTANCE +DC GTRT,14000 ;RIGHT+11 BITS OF ANGLE +DC GTSHED,20000 ;SET HEADING+11 BITS OF HEADING +DC GTMOVE,24000 ;MOVE+11 BITS OF SPEED +DC GTSPIN,30000 ;SPIN+11 BITS OF SPEED +DC GTDISP,34000 ;DISPLAY, ADDRESS IN NEXT WORD +DC GTSTXY,40000 ;SET X+11 BITS, Y IN NEXT WORD +DC GTDLXY,44000 ;DELTA X+11 BITS, Y IN NEXT WORD +DC GTCS,50000 ;CLEAR SCREEN +DC GTRUB,50000 ;RUBOUT+11 BITS OF WORDS TO RUB OUT (SHOULD BE NEGATIVE) +DC GTNSNP,56000 ;NEW SNAP, ADDRESS IN SAME WORD (10 BITS) +DC GTNDIS,60000 ;NEW DISPLAY, ADDRESS IN SAME WORD +DC GTUSE,52000 ;USE DEVICE, 0=DISPALY, 1=TURTLE, 2=PLOTTER +DC GTUDIS,GTUSE ;USE DISPLAY +DC GTUTUR,GTUSE+1 ;USE TURTLE +DC GTUPLT,GTUSE+2 ;USE PLOTTER +DC GTGTST,4004 ;GET TURTLE STATE +DC GTLPON,4001 ;SET TURTLE LAMPS ON +DC GTLPOF,4002 ;LAMPOFF +DC GTTOOT,4003 ;TOOT TURTLE +dc gtdpoi,54000 ;dpoint + 8 bits of arg +dc gtchan,55000 ;change + 8 bits of arg +dc gtendc,55400 ;endchange +.ENDC + +;FLAGS USED FOR DFLAGS +DC PENUF,1 ;PEN UP +DC HIDETF,4 ;TURTLE NOT SHOWN +DC TURTF,10 +DC TEMF,20 +DC DISPF,40 ;DISPLAY IN USE +DC WRAPF,100 ;WRAP AROUND MODE +DC PLOTF,200 ;PLOTTER IN USE +DC TVF,400 ;THIS IS A TV DISPLAY +DC CLIPF,1000 ;CLIP MODE + +;Flags for color in DFLAGS word of display flags. +.IFNZ COLOR +COLORF==2000 ;On if color display in use. +ERASEF==4000 ;Eraser doesn't seem to be implemented. [:ERASERSTATE] in Lisp. +XORF==10000 ;:XORSTATE +COLORW==20000 ;Color write mode is on. +.ENDC + +.IFNZ TS +.=40 +.IFF +.=340 +.ENDC +.IFNZ RXDISK +.INSRT MARG;RXLOA1 > +.ENDC + +.IFNZ LSMAP +DC MAPCSR,177600 +DC MAPON,200 +DC MAPADR,MAPCSR+2 +DC MAPHCK,74 ;MAP HACK PAGE +DC MAPHCA,MAPHCK*2000 ;ADDRESS OF SAME +DC PARCSR,MAPADR+2 +DC PAROK,200 +DC PARINT,100 +DC PARBDH,40 +DC PARBDL,20 +DC PARADR,PARCSR+2 +.ENDC diff --git a/src/nlogo/pure.96 b/src/nlogo/pure.96 new file mode 100755 index 00000000..cf6b03e3 --- /dev/null +++ b/src/nlogo/pure.96 @@ -0,0 +1,2157 @@ +.SBTTL PURE STORAGE + VERSIO + +;START OF PURE CONSTANTS +;ASCII STRING OF OPTION TEXT + +.MACRO OPTEXT A,B + .ASCII /A==B/ + .BYTE 15 +.ENDM + +PURES:: ;START OF PURE FOR LSI SYS CHECKER +.IF Z LSI +OPTS: .IRP A, + OPTEXT A,\A + .ENDR + .BYTE 0 + .EVEN +.ENDC + +.IF NZ LSI +OPTS: .IRP A, + OPTEXT A,\A + .ENDR + .BYTE 0 + .EVEN +.ENDC + +TBCCHR: .WORD 117,112,105,40 ;CONTROL CHARACTERS FOR TBOX +TURN: 15 + 146/2 +MBDN: 150/2 +PLTDVN: 152/2 + +INODES: 0 ;NODE 0 + DC N,NODESP + 0 + DC $$,1 +.IFNZ ENG +TRUE=LSTR+$$ + NODE SSTR+$.,"TR + NODE SSTR,"UE +FALSE=LSTR+$$ + NODE SSTR+$.,"FA + NODE SSTR+$.,"LS + NODE SSTR,'E +.ENDC +.IFNZ FR + VRAI=LSTR+$$ + NODE SSTR+$.,"VR + NODE SSTR,"AI + FAUX=LSTR+$$ + NODE SSTR+$.,"FA + NODE SSTR,"UX +.ENDC +.IFNZ ENG +$TOTO=LSTR+$$ + NODE SSTR,"TO +.ENDC +.IFNZ FR +$POURX=LSTR+$$ + NODE SSTR+$.,"PO + NODE SSTR,"UR +.ENDC + + LUNN=$$-1 + NNN=$$ ;NEXT NODE NO. +SOFN=NNN ;START OF FREE NODES +ASOFN=. + +.IFNZ TVS +VSWMC: VSWMC1 ;Video switch magic constants. + VSWMC2 + VSWMC3 + VSWMC4 + +CRMC: CRMC1 ;Console register magic constants. + CRMC2 + CRMC3 + CRMC4 + +DRAWTB: DRAWH ;HORIZONTAL LINE + DRAWV ;VERTICAL LINE + +POIMSK: +.REPT 16. + -<1_<15.-.RPCNT>+1> +.ENDR + + STARMSK: ;Table of masks for rightmost part of word. + 0 ;For stuffing into TVMSK register, the Nth + 100000 ;entry in the table allows writing all bits except + 140000 ;the leftmost (1- N) bits. + 160000 + 170000 + 174000 + 176000 + 177000 + 177400 + 177600 + 177700 + 177740 + 177760 + 177770 + 177774 + 177776 + +STOPMSK: ;Table of masks to write leftmost N bits. + 77777 + 37777 + 17777 + 7777 + 3777 + 1777 + 777 + 377 + 177 + 77 + 37 + 17 + 7 + 3 + 1 + 0 +.ENDC + +BREAKS: RLWAIT ;WAITING FOR USER TO TYPE LINE + TYWAIT ;WAITING FOR .BYTI FOR .TYI +.IFNZ SITS + SLWAIT ;WAITING FOR .SLEEP TO FINISH + DTWAIT ;WAITING FOR .BYTI +.ENDC + 0 +;THEM'S THE BREAKS! + +.IFNZ FILDSK +.IFZ UNIX +PODIRT: PODIRP ;PARENT + PODIRD ;DIRECTORY + PODIRF ;FILE + PODIRL ;NOT IMPLEMENTED + PODIRS ;SELF + PODIRL ;LINK + PODIRL ;NOT IMPLEMENTED + PODIRL ;NOT IMPLEMENTED +.ENDC +.ENDC + +.IFNZ UNIX +.RMDIR: .ASCIZ "/bin/rmdir" ; PRIVILEGED PROCEDURE TO REMOVE DIRECTORY +.RMARG: #.RMDIR ; ARGUMENT VECTOR FOR EXEC CALL + #NAME + 0 + +.LS: .ASCIZ "/bin/ls" ;DIR LISTER FOR POI +.LSARG: #.LS + #.LSFLG + 0 +.LSFLG: .ASCIZ "-s" ;INCLUDE SIZE IN LISTING + +.FIND: .ASCIZ "/bin/find" ;DIR LISTER FOR POTREE +.FIARG: #.FIND + #.FIAR1 ;DIR TO SEARCH + #.FIAR2 ;WHAT TO DO WITH ENTRIES + 0 +.FIAR1: .ASCIZ "." ;SEARCH CURRENT DIR +.FIAR2: .ASCIZ "-print" ;PRINT EVERY PATHNAME + +.MKDIR: .ASCIZ "/bin/mkdir" ;CRINDEX +.MKARG: #.MKDIR + #NAME + 0 + +.LPR: .ASCIZ "/bin/lpr" ;LINEPRINT +.LPARG: #.LPR + #NAME + 0 + +.ENDC + + +.IFNZ FILDSK +MAILNM: .ASCIZ /MAIL/ ;MAIL DIR. NAME +.EVEN + +;DATE-TIME TABLE + ;BIT FORMAT OF DATE & TIME WORDS IS: + ; YR MO DA HR MIN SEC/2 +; DATE: 7 4 5 TIME: 5 6 5 + +DTTAB: -5 ;MONTH SHIFT + 177760 ;BIC # + 0 ;MULT. FACTOR + '/ ;DELIMITER CHAR + + 0 ;DAY SHIFT + 177740 ;BIC # + 0 ;MULT. FACTOR + '/ ;DELIMITER CHAR + + -9. ;YEAR SHIFT + 177600 ;BIC # + 0 ;MULT. FACTOR + ' ;DELIMITER CHAR + + -11. ;HOUR SHIFT + 177740 ;BIC # + 0 ;MULT. FACTOR + ': ;DELIMITER CHAR + + -5 ;MINUTE SHIFT + 177700 ;BIC # + 0 ;MULT. FACTOR + ': ;DELIMITER CHAR + + 0 ;SECONDS/2 SHIFT + 177740 ;BIC # + 1 ;MULT. FACTOR + ' ;DELIMITER CHAR +.ENDC + + .IFNZ HALFLG + H.1.1: 40214 ;CONSTANT 1.1 FOR ORBIT HACK + 146315 +.ENDC + +;FLOATING POINT CONSTANTS +FLTTOL: .WORD 35603,11156 ;FLOATING POINT TOLERANCE 0.001 +SIN120: .WORD 40135,131730 ;SIN 120 OR 0.86602544 +COS120: .WORD 140000,0 ;COS 120 OR -0.5 +SIN240: .WORD 140135,131731 ;SIN 240 OR -0.86602544 +COS240: .WORD 140000,0 ;COS 240 OR -0.5 +FPC0.1: .WORD 37314,146314 ;FLOATING CONSTANT 0.1 + +;THESE CONSTANTS USED BY ARCTAN ROUTINE ("ATAN") +PI: ;.FLT4 3.141592653589793 + .WORD 40511,7732,121041,64303 ;PI = 3.141592653589793 +PITWO: ;.FLT4 1.570796326794896 + .WORD 40311,7732,121041,64303 ;PI/2 = 1.570796326794896 +ACOPI: .WORD 41545,27340,151436,7675 ;180/PI +TMNI: ;.FLT4 1.0E-9 + .WORD 30611,70137,40466,132246 +ATANTB: ;ATAN TABLE +B3: ;.FLT4 1.448631538 + .WORD 40271,66302,15725,1745 +A3: ;.FLT4 -.2647686202 + .WORD 137607,107700,124610,33414 +B2: ;.FLT4 3.316335425 + .WORD 40524,37326,170074,36637 +A2: ;.FLT4 -7.106760045 + .WORD 140743,65224,5271,66163 +B1: ;.FLT4 6.762139240 + .WORD 40730,61561,152331,105643 +A1: ;.FLT4 3.709256262 + .WORD 40555,62164,60161,76074 +B0: ;.FLT4 .1746554388 + .WORD 37462,154340,13333,126636 + + + + +;FORMAT FOR AN ERROR IS +; BEGER HNV +; ENGERR +; ENGERR <.ASCII ^/ HAS NO VALUE /> +; MIDERR +; FRERR +; FRERR <.ASCII ^/ N'A PAS RECU DE VALEUR/> +; ENDERR + +.MACRO BEGER X +.IF NDF PASS2 +DC X,ERMNO +DC ERMNO,ERMNO+1 +.ENDC +DC FOO,. + .ASCII /X/ +.=FOO+4 +DC BARF,0 + .IRPC Q,X + DC BARF,<<<''Q-'A+1>&17>+> + .ENDM + BARF +.IFZ NOERTX +.IF DF PASS2 +DC BAR,. +.=ERTABE +.IIF Z LSI, FOO +.IIF NZ LSI, FOO-ERTXT +DC ERTABE,. +.=BAR +.ENDC +.ENDC +.ENDM + +.MACRO ENGERR S +.IFZ NOERTX +.IIF NZ ENG,S +.ENDC +.ENDM + + +.MACRO FRERR S +.IFZ NOERTX +.IIF NZ FR,S +.ENDC +.ENDM + +.MACRO MIDERR +.IFZ NOERTX +.IIF NZ FR&ENG,.BYTE 0 +.ENDC +.ENDM + +.MACRO ENDERR +.IFZ NOERTX +.BYTE 0 +.EVEN +.ENDC +.ENDM + +.MACRO EROT A +.BYTE A'.N +.ENDM + +.MACRO JROT A +.IIF NDF A'.R, DC A'.R,A +.ENDM + +.MACRO ERRM A,C +.IIF B C,JROT A +.IIF NB C,DC A'.R,C + A'.R + DC A'.N,ERRNO +DC ERRNO,ERRNO+1 +.ENDM + + +DC ERRNO,200 + .SBTTL ERROR TABLES + + +ROTTAB: ERRM PNAB,PNODAB + ERRM PRLO + ERRM TYO + ERRM PRCO + ERRM PRS1 + ERRM PRCT + ERRM GDBY,FBUGB + ERRM CTIT + ERRM HNM + ERRM PAE + ERRM PRAB,PROAB + ERRM TDE + ERRM BUG + ERRM BRK + ERRM WTAA + ERRM WTAB + ERRM WTIB + ERRM NCF + ERRM GDE + ERRM PRFN + ERRSRT: + +ERTAB: +DC ERTABE,. +.IF NDF PASS2 +DC ERMNO,0 +DC ERTXT,0 +.IFF +.IIF Z LSI, DC ERTXT,ERTAB+ +;FOR THE LSI ERTXT IS DEFINED ELSEWHERE +.ENDC +.=ERTXT + +BEGER BAT +ENGERR <.ASCII /BAD ARRAY TYPE./> +MIDERR +FRERR <.ASCII /MAUVAIS TYPE DE VECTEUR/> +ENDERR + +.IFNZ FILDSK +BEGER BDD +ENGERR <.ASCII /BAD DISK NAME./> +MIDERR +FRERR <.ASCII /MAUVAIS NOM DU DISQUE/> +ENDERR +.ENDC + +BEGER BRK +ENGERR +MIDERR +FRERR +ENDERR + + +BEGER BUG +ENGERR +MIDERR +FRERR +ENDERR + +DC .BUG.,ERROR+BUG + + +BEGER COP +ENGERR <.ASCII /CHAR /> +ENGERR +ENGERR <.ASCII / OUT OF PLACE./> +MIDERR +FRERR <.ASCII /CAR /> +FRERR +FRERR <.ASCII / HORS POSITION/> +ENDERR + +.IFNZ CPF +BEGER CPX +ENGERR <.ASCII /PRINTER NOT AVAILABLE/> +MIDERR +FRERR <.ASCII /AVAILABLE PRINTER NOT/> +ENDERR +.ENDC + + +BEGER CTIT +ENGERR <.ASCII /YOU ARE ALREADY DEFINING /> +ENGERR +MIDERR +FRERR <.ASCII /VOUS ETES ENTRAIN DE DEFINIR /> +FRERR +ENDERR + + + +BEGER DIU +ENGERR <.ASCII /DEVICE IN USE./> +MIDERR +FRERR <.ASCII /L'APPAREIL N'EST PAS DISPONIBLE/> +ENDERR + + +.IFNZ MULTTY +BEGER DNA +ENGERR +ENGERR <.ASCII / IS NOT A DEVICE NAME./> +MIDERR +FRERR +FRERR <.ASCII / N'EST PAS UN APPAREIL./> +ENDERR +.ENDC + +.IFNZ FILDSK +BEGER DNR +ENGERR <.ASCII /DEVICE NOT READY./> +MIDERR +FRERR <.ASCII /L'APPAREIL N'EST PAS PRET/> +ENDERR +.ENDC + +.IFNZ MUSBOX +BEGER DOR +ENGERR <.ASCII /DURATION OUT OF RANGE/> +MIDERR +FRERR <.ASCII /DUREE TROP LONGUE/> +ENDERR +.ENDC + + +BEGER ELW +ENGERR +ENGERR <.ASCII / - EDIT LINE WHAT?/> +MIDERR +FRERR <.ASCII / EDITE QUELLE LIGNE??/> +ENDERR + +.IFNZ FILDSK +BEGER ENDR +ENGERR <.ASCII /ENTRY NOT A DIRECTORY./> +MIDERR +FRERR <.ASCII /CETTE ENTREE N'EST PAS CELLE D'UN UTILISATEUR/> +ENDERR +.ENDC + +BEGER ERP +ENGERR <.ASCII /UNEXPECTED RIGHT PARENTHESIS./> +MIDERR +FRERR <.ASCII /PARENTHESE DROITE SUPERFLUE/> +ENDERR + + +BEGER ERW +ENGERR <.ASCII /CAN'T ERASE /> +ENGERR +MIDERR +FRERR +FRERR <.ASCII / - EFFACE QUOI?/> +ENDERR + + +.IFNZ FILDSK +BEGER FAO +ENGERR <.ASCII /FILE ALREADY OPEN./> +MIDERR +FRERR <.ASCII /FICHIER DEJA OUVERT/> +ENDERR +.ENDC + +BEGER FBUG +ENGERR <.ASCII /FATAL SYSTEM BUG./> +ENGERR +MIDERR +FRERR <.ASCII /BUG FATAL AU SYSTEME/> +FRERR +ENDERR + +.IFNZ FILDSK +BEGER FNF +ENGERR +ENGERR <.ASCII /: /> +ENGERR +ENGERR <.ASCII / /> +ENGERR +MIDERR +FRERR +FRERR <.ASCII /: /> +FRERR +FRERR <.ASCII / /> +FRERR +ENDERR +.ENDC + +.IFNZ SITS +BEGER SIT +ENGERR <.ASCII /NOT IN SITS YET/> +MIDERR +FRERR <.ASCII /N'EST EN SITS/> +ENDERR +.ENDC + +BEGER HNM +ENGERR <.ASCII /YOU HAVEN'T TOLD ME HOW TO /> +ENGERR +MIDERR +FRERR +FRERR <.ASCII / N'EXISTE PAS./> +ENDERR + +BEGER HNV +ENGERR +ENGERR <.ASCII / HAS NO VALUE./> +MIDERR +FRERR +FRERR <.ASCII / N'A PAS RECU DE VALEUR/> +ENDERR + +.IFNZ FILDSK +BEGER GDE +ENGERR +ENGERR <.ASCII /: /> +ENGERR +MIDERR +FRERR +FRERR <.ASCII /: /> +FRERR +ENDERR +.ENDC + +.IFNZ FILDSK +BEGER IFN +ENGERR +ENGERR <.ASCII / IS INVALID FILE NAME./> +MIDERR +FRERR +FRERR <.ASCII / NE PEUT SERVIR COMME NOM DE FICHIER/> +ENDERR +.ENDC + +BEGER INF1 +ENGERR +ENGERR <.ASCII / IS IN THE WRONG PLACE./> +MIDERR +FRERR +FRERR <.ASCII / EST A LA MAUVAISE PLACE/> +ENDERR + +BEGER INVN +ENGERR <.ASCII /INVALID NODE./> +MIDERR +FRERR <.ASCII /NODE INVALIDE/> +ENDERR + +.IFNZ SITS +BEGER ITN +ENGERR <.ASCII /A NONEXISTANT TURTLE?/> +MIDERR +FRERR <.ASCII /NUMERO DE TORTUE INEXISTANT/> +ENDERR +.ENDC + +.IFNZ MUSBOX +BEGER IVV +ENGERR <.ASCII /INVALID VOICE NUMBER/> +MIDERR +FRERR <.ASCII /NUMERO DE PISTE INEXISTANT/> +ENDERR +.ENDC + +BEGER LDE +ENGERR <.ASCII /LINE /> +ENGERR +ENGERR <.ASCII / DOESN'T EXIST./> +MIDERR +FRERR <.ASCII /LIGNE /> +FRERR +FRERR <.ASCII / INEXISTANTE/> +ENDERR + +BEGER LNTB +ENGERR <.ASCII /LINE NUMBER TOO BIG./> +MIDERR +FRERR <.ASCII /NUMERO DE LIGNE TROP GRAND/> +ENDERR + + +BEGER NAS +ENGERR <.ASCII /NOT ENOUGH ARRAY SPACE./> +MIDERR +FRERR <.ASCII /PAS ASSEZ D'ESPACE POUR LA MATRICE/> +ENDERR + +.IFNZ FILDSK +BEGER NCD +ENGERR <.ASCII /NO CURRENT DISK./> +MIDERR +FRERR <.ASCII /NO CURRENT DISK./> +ENDERR + +BEGER NFO +ENGERR <.ASCII /NO FILE OPEN/> +MIDERR +FRERR <.ASCII /PAS DU FICHIER OUVERT/> +ENDERR +.ENDC + +BEGER NCF +ENGERR <.ASCII /NO CATCH FOUND FOR TAG /> +ENGERR +ENGERR +MIDERR +FRERR <.ASCII /TAG FOR FOUND CATCH NO /> +FRERR +FRERR +ENDERR + +.IFNZ SITS +BEGER NDU +ENGERR <.ASCII /YOU DON'T HAVE A DISPLAY CONSOLE/> +MIDERR +FRERR <.ASCII /CE TERMINAL NE PEUT AVOIR UN ECRAN/> +ENDERR +.ENDC + +.IFNZ SITS +BEGER NDV +ENGERR <.ASCII /NO DISPLAY AVAILABLE./> +MIDERR +FRERR <.ASCII /PLUS D'ECRANS DISPONIBLES/> +ENDERR +.ENDC + +BEGER NEC +ENGERR +ENGERR <.ASCII / CAN'T BE EDITED./> +MIDERR +FRERR +FRERR <.ASCII / N'EST PAS UN COMMANDEMENT D'EDITION/> +ENDERR + +.IFNZ FILDSK +BEGER NFO +ENGERR <.ASCII /NO FILE OPEN!/> +MIDERR +FRERR <.ASCII /FICHIER N'EST PAS OUVERT!/> +ENDERR +.ENDC + +BEGER NIP +ENGERR <.ASCII /NOTHING INSIDE PARENTHESES./> +MIDERR +FRERR <.ASCII /LES PARENTHESES SONT VIDES/> +ENDERR + +.IFNZ MUSBOX +BEGER NOG +ENGERR <.ASCII /NOTE OUT OF RANGE/> +MIDERR +FRERR <.ASCII /NOTE HORS LIMITE/> +ENDERR +.ENDC + +BEGER NOU +ENGERR +ENGERR <.ASCII / DIDN'T OUTPUT!/> +MIDERR +FRERR +FRERR <.ASCII / N'A PAS PRODUIT D'OUTPUT/> +ENDERR + +BEGER NSL +ENGERR <.ASCII /NO STORAGE LEFT./> +MIDERR +FRERR <.ASCII /PLUS D'ESPACE DISPONIBLE/> +ENDERR + +.IFNZ SITS +BEGER NTB +ENGERR <.ASCII /THORTON BOX SLOTS NOT AVAILABLE/> +MIDERR +FRERR <.ASCII /IL N'Y A PAS DE TBOX/> +ENDERR +.ENDC + +BEGER NTF +ENGERR +ENGERR <.ASCII / NOT "TRUE OR "FALSE ./> +MIDERR +FRERR <.ASCII /NI "VRAI NI "FAUX/> +ENDERR + +.IFNZ TVS +BEGER NTVS +ENGERR <.ASCII /TVS CANNOT DO THIS FUNCTION/> +MIDERR +FRERR <.ASCII /NOT ON TVS YOU DUMMY!/> +ENDERR +.ENDC + +.IFNZ TVS +BEGER OTVS +ENGERR <.ASCII /ONLY ON TVS/> +MIDERR +FRERR <.ASCII /ONLY ON TVS/> +ENDERR +.ENDC + +.IFNZ GTL +BEGER OGT +ENGERR <.ASCII /ONLY ON 2500'S/> +MIDERR +FRERR <.ASCII /ONLY ON 2500'S/> +ENDERR +.ENDC + +BEGER OIP +ENGERR <.ASCII /ONLY WHEN DEFINING OR EDITING A PROCEDURE./> +MIDERR +FRERR <.ASCII /POSSIBLE SEULEMENT A L'INTERIEUR D'UNE PROCEDURE/> +ENDERR + + +BEGER OOB +ENGERR <.ASCII /OUT OF BOUNDS/> +MIDERR +FRERR <.ASCII /HORS LIMITE/> +ENDERR + + +BEGER OOP +ENGERR +ENGERR <.ASCII / OUT OF PLACE./> +MIDERR +FRERR +FRERR <.ASCII / HORS POSITION/> +ENDERR + +BEGER OOT +ENGERR <.ASCII /OUT OF TOKENS./> +MIDERR +FRERR <.ASCII /JE SUIS VIDEE/> +ENDERR + + +BEGER PAE +ENGERR <.ASCII /YOU HAVE ALREADY TOLD ME HOW TO /> +ENGERR +ENGERR +MIDERR +FRERR <.ASCII /PROCEDURE /> +FRERR +FRERR +FRERR <.ASCII / DEJA EXISTANTE/> +ENDERR + +BEGER PBE +ENGERR +ENGERR <.ASCII / IS BEING EDITED./> +MIDERR +FRERR +FRERR <.ASCII / EST SOUS EDITION/> +ENDERR + +BEGER PBEX +ENGERR <.ASCII /CAN'T EDIT PROCEDURE THAT IS EXECUTING./> +MIDERR +FRERR <.ASCII /NE PEUX EDITER SOUS EXECUTION./> +ENDERR + + +BEGER PNH +ENGERR <.ASCII /PROCEDURE /> +ENGERR +ENGERR <.ASCII / NOT HERE./> +MIDERR +FRERR <.ASCII /LA PROCEDURE /> +FRERR +FRERR <.ASCII / N'EST PAS ICI/> +ENDERR + + +BEGER ROB +ENGERR <.ASCII /INDEX REFERENCE OUT OF BOUNDS./> +MIDERR +FRERR <.ASCII /INDEX DE REFERENCE HORS LIMITE/> +ENDERR + + +BEGER RTB +ENGERR <.ASCII /ARITHMETIC RESULT TOO BIG./> +MIDERR +FRERR <.ASCII /NOMBRE TROP GRAND/> +ENDERR + +BEGER SHW +ENGERR <.ASCII /CAN'T PRINTOUT "/> +ENGERR +MIDERR +FRERR +FRERR <.ASCII / IMPRIME QUOI?/> +ENDERR + +.IFNZ NDISP +BEGER STDP +ENGERR <.ASCII /TOO MANY SNAPS./> +MIDERR +FRERR <.ASCII /TROP DE PHOTOS/> +ENDERR +.ENDC + +.IFNZ MULTTY +BEGER TDE +ENGERR <.ASCII /TTY /> +ENGERR +ENGERR <.ASCII / DOESN'T EXIST./> +MIDERR +FRERR <.ASCII /TERMINAL /> +FRERR +FRERR <.ASCII / NON EXISTANT/> +ENDERR +.ENDC + +.IFNZ NDISP +BEGER TGDZ +ENGERR <.ASCII /INPUT TO RIGHT OR LEFT TOO LARGE/> +MIDERR +FRERR <.ASCII /INPUT TROP GRAND/> +ENDERR +.ENDC + +BEGER TGD +ENGERR <.ASCII /THE TURTLE IS DIZZY./> +MIDERR +FRERR <.ASCII /LA TORTUE EST FOU./> +ENDERR + +BEGER TIP +ENGERR <.ASCII /TOO MUCH INSIDE PARENTHESES./> +MIDERR +FRERR <.ASCII /TROP DE PARENTHTHESES INTERIEURES/> +ENDERR + + +BEGER TMAP +ENGERR <.ASCII /TOO MANY ARGS!!!/> +MIDERR +FRERR <.ASCII /TROP D'INPUTS!!!/> +ENDERR + +BEGER TML +ENGERR <.ASCII /TOO MANY LINES/> +MIDERR +FRERR <.ASCII /TROP DE LIGNES/> +ENDERR + +BEGER UBL +ENGERR +ENGERR <.ASCII / IS USED BY LOGO./> +MIDERR +FRERR +FRERR <.ASCII / EST UTILISE PAR LOGO/> +ENDERR + +BEGER UDA +ENGERR <.ASCII /YOU HAVE NOT DEFINED ARRAY "/> +ENGERR +MIDERR +FRERR <.ASCII /MATRICE NON DEFINIE/> +ENDERR + +BEGER UEL +ENGERR <.ASCII /UNEXPECTED END OF LINE./> +MIDERR +FRERR <.ASCII /ENONCE INCOMPLET/> +ENDERR + + +BEGER UELX +ENGERR +ENGERR <.ASCII / NEEDS MORE INPUTS./> +MIDERR +FRERR +FRERR <.ASCII / A BESOIN DE PLUS D'INPUT(S)/> +ENDERR + +BEGER VTD +ENGERR +ENGERR <.ASCII / NEEDS A TURTLE OR A DISPLAY/> +MIDERR +FRERR +FRERR <.ASCII / AVEZ-VOUS DEMANDE UNE TORTUE OU UN ECRAN/> +ENDERR + +BEGER VTU +ENGERR +ENGERR <.ASCII / NEEDS A TURTLE/> +MIDERR +FRERR +FRERR <.ASCII / AVEZ-VOUS DEMANDE UNE TORTUE/> +ENDERR + +BEGER WDIM +ENGERR <.ASCII /BAD DIMENSION(S)./> +MIDERR +FRERR <.ASCII /MAUVAISES DIMENSIONS/> +ENDERR + + +BEGER WDW +ENGERR <.ASCII /YOU DON'T SAY WHAT TO DO WITH /> +ENGERR +MIDERR +FRERR <.ASCII /QUE DOIS-JE FAIRE AVEC /> +FRERR +ENDERR + + +BEGER WIT +ENGERR +ENGERR <.ASCII / CAN'T BE AN INPUT./> +MIDERR +FRERR +FRERR <.ASCII / NE PEUT SERVIR D'INPUT/> +ENDERR + +BEGER WNA +ENGERR <.ASCII /WRONG NUMBER OF ARGUMENTS TO /> +ENGERR +MIDERR +FRERR <.ASCII /NOMBRE INCORRECT D'INPUTS POUR /> +FRERR +ENDERR + +BEGER WTA +ENGERR +ENGERR <.ASCII / DOESN'T LIKE /> +ENGERR +ENGERR <.ASCII / AS INPUT./> +MIDERR +FRERR +FRERR <.ASCII / N'AIME PAS RECEVOIR /> +FRERR +FRERR <.ASCII / COMME INPUT./> +ENDERR + +BEGER WTAA +ENGERR +ENGERR <.ASCII / DOESN'T LIKE /> +ENGERR +ENGERR +ENGERR <.ASCII / AS INPUT./> +MIDERR +FRERR +FRERR <.ASCII / N'AIME PAS RECEVOIR /> +FRERR +FRERR +FRERR <.ASCII / COMME INPUT./> +ENDERR + +BEGER WTAB +ENGERR +ENGERR <.ASCII / DOESN'T LIKE /> +ENGERR +ENGERR +ENGERR <.ASCII / AS INPUT./> +MIDERR +FRERR +FRERR <.ASCII / N'AIME PAS RECEVOIR /> +FRERR +FRERR +FRERR <.ASCII / COMME INPUT./> +ENDERR + +.IF NZ MUSBOX +BEGER WTIB +ENGERR +ENGERR <.ASCII / DOESN'T LIKE /> +ENGERR +ENGERR <.ASCII / AS INPUT./> +MIDERR +FRERR +FRERR <.ASCII / N'AIME PAS RECEVOIR /> +FRERR +FRERR <.ASCII / COMME INPUT./> +ENDERR +.ENDC + +.IF Z LSI +.IF NDF PASS2 +.=.++ERTAB +.ENDC +.IFF +.IIF NDF PASS2,DC ERTXTL,. +.=ERTAB+ +.ENDC + +;SPECIAL DISK ERROR STUFF +.IFNZ ENG +ENGDER: +.BYTE .EBFN ;CAN'T CREATE THAT + .ASCIZ /BAD FILE NAME/ +.BYTE .ECDD ;CAN'T DELETE DIRECTORY THAT ISN'T EMPTY + .ASCIZ /CAN'T DELETE NON-EMPTY DIRECTORY/ +.BYTE .EDFL ;DISK FULL + .ASCIZ /DISK FULL/ +.BYTE .EDRF ;DIRECTORY FULL + .ASCIZ /DIRECTORY FULL/ +.BYTE .EDSKE ;DISK ERROR + .ASCIZ /DISK ERROR/ +.BYTE .EDVBE ;VERY BAD DISK ERRROR + .ASCIZ /BAD DISK ERROR, CHECK DISK/ +.BYTE .EEAE ;NO, FILE ALREADY EXISTS + .ASCIZ /ENTRY ALREADY EXISTS/ +.BYTE .EFNF ;FILE NOT FOUND + .ASCIZ /ENTRY NOT FOUND/ +.BYTE .ENIS ;NO SPACE + .ASCIZ /TOO MANY FILES OPEN/ +.BYTE 0 + .ASCIZ /UNKNOWN ERROR/ +.ENDC + +.IFNZ FR +FRDER: +.BYTE .EBFN ;CAN'T CREATE THAT + .ASCIZ /BAD FILE NAME/ +.BYTE .ECDD ;CAN'T DELETE DIRECTORY THAT ISN'T EMPTY + .ASCIZ /JE NE PEUX DETRUIRE CETTE ENTREE/ +.BYTE .EDFL ;DISK FULL + .ASCIZ /LE DISQUE EST REMPLI/ +.BYTE .EDRF ;DIRECTORY FULL + .ASCIZ /DIRECTORY FULL/ +.BYTE .EDSKE ;DISK ERROR + .ASCIZ /DISK ERROR/ +.BYTE .EDVBE ;VERY BAD DISK ERRROR + .ASCIZ /BAD DISK ERROR, CHECK DISK/ +.BYTE .EEAE ;NO, FILE ALREADY EXISTS + .ASCIZ /ENTREE DEJA EXISTANTE/ +.BYTE .EFNF ;FILE NOT FOUND + .ASCIZ /N'AI PAS TROUVE CE ENTRY/ +.BYTE .ENIS ;NO SPACE + .ASCIZ /TROP DES FICHIERS OUVERT/ +.BYTE 0 + .ASCIZ /JE SAIS PAS/ +.ENDC +.EVEN + + .SBTTL SYSTEM OBLIST + +DC VARIAB,10 ;FOR VARIABLE NUMBER OF ARGUMENTS +DC ARGMSK,177770 ;FOR MASKING ALL BUT NUMBER OF ARGS +DC YINFIX,20 ;"YES INFIX" FLAG FOR OLE + +DC VNAF,VARIAB*400 ;FOR EVAL + +;SOE FIELDS 1.==RIGHT BYTE (EVEN ADDR) 2.==LEFT BYTE + ; 1.1==RIGHT BIT 2.8==LEFT BIT +DC ABRFLG,1 +DC FRFLG,2 +DC ENGFLG,4 +DC PFRFLG,10 + ;1.4-1.8 UNUSED + ;2.1-2.2 "STANDARD" NO. OF INPUT ARGS + ;2.3 VNAF 1==CAN TAKE "ANY" NO. OF ARGS + ;2.5 INFIX 1==THIS IS AN INFIX PROCEDURE + ;2.6-2.8 PRECEDENCE + + .MACRO NGPTWO A + DC NGP2,NGP2*2 + DC FOO,A + .IFLE NGP2-FOO + NGPTWO A + .ENDC + .ENDM + +;**************************************************** +;MACRO TO DEFINE SYSTEM OBLIST ELEMENTS +;THE PARAMETERS ARE: +;1) THE PRINT NAME +;2) PRINT NAME OF ABBREVIATION +;3) THE NAME OF THE POINTER TO THE OBLIST ELEMENT. +;4) THE ADDRESS OF THE PROGRAM +;5) THE PRECEDENCE. A NUMBER FROM 0-7 +;6) THE NUMBER OF ARGUMENTS, AND THE SYMBOL "VARIABLE" +; IF IT CAN ALSO TAKE A VARIABLE NUMBER OF ARGUMENTS +;7) THE SYMBOL "YINFIX" IF THIS IS AN INFIX OPERATOR + ;8) IF 0, DONT ASSEMBLE THIS PRIMITIVE + + + + ;VERSION FOR OBLIST ELEMENTS THAT ARE BOTH FRENCH AND ENGLISH +.MACRO OLB PN,ABR,OB,AD,PR,NU,QI,X +.IIF B X,.IFZ 0 +.IIF NB X,.IFNZ X +.IF NDF PASS2 +DC NUMOBS,NUMOBS+1 +.ASCIZ @PN@ +.EVEN +.ENDC +.IF DF PASS2 +OBADD2-SOBLST +DC OBADD1,. +.=OBADD2 +.IFB OB +.IIF NDF PASS2,.IIF DF $'PN,.ERROR PN OBLIST CONFLICT +DC $'PN,.-SOBLST/2 +.ENDC +.IFNB OB +.IIF NDF PASS2,.IIF DF $'OB,.ERROR OB OBLIST CONFLICT +DC $'OB,.-SOBLST/2 +.ENDC +DC OBX1,NU+0 +DC OLEAD,. +.IIF B PR,DC OBX2,PREPRI*40 +.IIF NB PR,DC OBX2,PR*40 +.BYTE ENGFLG!FRFLG,QI+OBX1+OBX2 +.IIF B AD,PN +.IIF NB AD,AD+0 +.ASCIZ @PN@ +.EVEN +OBADD2=. +.=OBADD1 +.ENDC +.IFNB ABR +ABRV ABR,OLEAD-SOBLST,ENGFLG!FRFLG +.ENDC +.ENDC +.ENDM + ;VERSION FOR ENGLISH ONLY +.MACRO OLE PN,ABR,OB,AD,PR,NU,QI,X +.IIF B X,.IFZ 0 +.IIF NB X,.IFNZ X +.IFNZ ENG +.IF NDF PASS2 +DC NUMOBS,NUMOBS+1 +.ASCIZ @PN@ +.EVEN +.ENDC +.IF DF PASS2 +OBADD2-SOBLST +DC OBADD1,. +.=OBADD2 +.IFB OB +.IIF NDF PASS2,.IIF DF $'PN,.ERROR PN OBLIST CONFLICT +DC $'PN,.-SOBLST/2 +.ENDC +.IFNB OB +.IIF NDF PASS2,.IIF DF $'OB,.ERROR OB OBLIST CONFLICT +DC $'OB,.-SOBLST/2 +.ENDC +DC OBX1,NU+0 +DC OLEAD,. +.IIF B PR,DC OBX2,PREPRI*40 +.IIF NB PR,DC OBX2,PR*40 +.BYTE ENGFLG,QI+OBX1+OBX2 +.IIF B AD,PN +.IIF NB AD,AD+0 +.ASCIZ @PN@ +.EVEN +OBADD2=. +.=OBADD1 +.ENDC +.IFNB ABR +ABRV ABR,OLEAD-SOBLST,ENGFLG +.ENDC +.ENDC +.ENDC +.ENDM + ;VERSION FOR FRENCH ONLY +.MACRO OLF PN,ABR,OB,AD,PR,NU,QI,X +.IIF B X,.IFZ 0 +.IIF NB X,.IFNZ X +.IFNZ FR +.IF NDF PASS2 +DC NUMOBS,NUMOBS+1 +.ASCIZ @PN@ +.EVEN +.ENDC +.IF DF PASS2 +OBADD2-SOBLST +DC OBADD1,. +.=OBADD2 +.IFB OB +.IIF NDF PASS2,.IIF DF $'PN,.ERROR PN OBLIST CONFLICT +DC $'PN,.-SOBLST/2 +.ENDC +.IFNB OB +.IIF NDF PASS2,.IIF DF $'OB,.ERROR OB OBLIST CONFLICT +DC $'OB,.-SOBLST/2 +.ENDC +DC OBX1,NU+0 +DC OLEAD,. +.IIF B PR,DC OBX2,PREPRI*40 +.IIF NB PR,DC OBX2,PR*40 +.BYTE FRFLG,QI+OBX1+OBX2 +.IIF B AD,PN +.IIF NB AD,AD+0 +.ASCIZ @PN@ +.EVEN +OBADD2=. +.=OBADD1 +.ENDC +.IFNB ABR +ABRV ABR,OLEAD-SOBLST,FRFLG +.ENDC +.ENDC +.ENDC +.ENDM + +.MACRO CDM A +DC A,<<.-SOBLSU>/2> +.ENDM + + .MACRO ABRV PN,OB,FLGS +.IF NDF PASS2 +DC NUMOBS,NUMOBS+1 +.ASCIZ @PN@ +.EVEN +DC OBLSTL,OBLSTL+4+OBL +.ENDC +.IF DF PASS2 +OBADD2-SOBLST +OBADD1=. +.=OBADD2 +ABRFLG!FLGS +OB +.ASCIZ \PN\ +.EVEN +OBADD2=. +.=OBADD1 +.ENDC +.ENDM + .MACRO OLT PN,ABR,FPN,FAB,AD,PR,NU,QI,X +.IIF B X,.IFZ 0 +.IIF NB X,.IFNZ X +.IFNZ ENG +.IF NDF PASS2 +DC NUMOBS,NUMOBS+1 +.ASCIZ @PN@ +.EVEN +.ENDC +.IF DF PASS2 +OBADD2-SOBLST +DC OBADD1,. +.=OBADD2 +DC OBX1,NU+0 +DC OLEAD,. +.IIF B PR,DC OBX2,PREPRI*40 +.IIF NB PR,DC OBX2,PR*40 +.BYTE ENGFLG,QI+OBX1+OBX2 +.IIF B AD,PN +.IIF NB AD,AD+0 +.ASCIZ @PN@ +.EVEN +OBADD2=. +.=OBADD1 +.ENDC +.IFNB ABR +ABRV ABR,OLEAD-SOBLST,ENGFLG +.ENDC +.ENDC +.IFNZ FR +.IF NDF PASS2 +DC NUMOBS,NUMOBS+1 +.ASCIZ @FPN@ +.EVEN +.ENDC +.IF DF PASS2 +OBADD2-SOBLST +DC OBADD1,. +.=OBADD2 +DC OBX1,NU+0 +DC OLEAD,. +.IIF B PR,DC OBX2,PREPRI*40 +.IIF NB PR,DC OBX2,PR*40 +.BYTE FRFLG,QI+OBX1+OBX2 +.IIF B AD,PN +.IIF NB AD,AD+0 +.ASCIZ @FPN@ +.EVEN +OBADD2=. +.=OBADD1 +.ENDC +.IFNB FAB +ABRV FAB,OLEAD-SOBLST,FRFLG +.ENDC +.ENDC +.ENDC +.ENDM + ;THE SYSTEM OBLIST + ;ADD ITEMS (EXCEPT FOR SPECIAL CHAR ITEMS) ALPHABETICALLY. + +.IF NDF PASS2 + DC NUMOBS,0 + .=.+4 ;RESERVE SPACE FOR THE TWO WORDS ON PASS TWO + .ENDC +.IF DF PASS2 +SOBLSU=SOBLST+-2 +SOOMX=. + 2+SOBLSU ;2 > THAN HIGHEST ADDR USED IN SYS OBLIST + DC NGP2,1 + NGPTWO SOBLSU-SOBLST+2 +SOBP2=. + NGP2 ;( SMALLEST POWER OF 2 >= NUMOBS )*2 +OBADD1=. +OBADD2=.+<2*NUMOBS> +OBSTRT=OBADD2 ;WHERE THE SYSTEM OBLIST ELEMENTS START + .ENDC + + ;PRIORITIES + DC PARPRI,1 ; ( ) + DC BAKPRI,2 ; _ __ IF TEST NOT BOTH EITHER + DC RELPRI,3 ; < = > + DC PREPRI,4 ;PRIORITY FOR MOST PREFIX PRIMITIVES + DC PMPRI,5 ; + - + DC MDPRI,6 ; * / \ + DC HIPRI,7 ; : ! # -- ++ + SOBLST: OLB 0 + OLB .ASCII,,ASCI,ASCI,,1 + OLB .CASESW,,CASESW,CASESW,,1 + OLB .CGCF,,CGCF,CGCF + OLB .CHAIN,,,,,1,,LSI&FILDSK + OLB .CLOSE,,CLOSE,CLOSE,,1,,MULTTY + OLT .CLOSEF,,.FERMEF,,.CLOSF,,0+VARIAB,,FILDSK + OLB .COLOR,,,.COLOR,,1,,COLOR + OLB .COLORINIT,,,.CLRINIT,,1,,COLOR + OLB .CPNF,,CPNF,CPNF + OLB .CTF,,CTF,CLRSTF,,,,DEBUGR + OLB .CTYI,,CTYI,CTYI + OLB .CTYO,,CTYO,CTYO,,1 + OLB .CURSET,,,,,2,,TVS + OLB .DEPOSIT,,,,,2 + OLB .EXAMINE,,,,,1 + OLB .DIAB,,,,,2,,LSI&LSPRNT + OLT .DRIB,,.DUPLICATA,.DUP,,,1,,FILDSK + OLB .ECHOSW,,ECHOSW,ECHOSW,,1 + OLT .ENDFILE,,.FINFICHIER,.FINF,FILEOF,,0+VARIAB,,FILDSK + OLT .FILEO,,.OUVERTF,,,,0+VARIAB,,FILDSK + OLT .FILEP,,.ENVOIE,,,,1+VARIAB,,FILDSK + OLT .FILEPOS,,.POSITIONF,.POSF,FILPOS,,0+VARIAB,,FILDSK + OLT .FILER,,.RAMENE,,,,0+VARIAB,,FILDSK + OLT .FILET,,.TAPEF,,.FILET,,1+VARIAB,,FILDSK + OLT .FILEW,,.RAMENEM,,.FILEW,,1+VARIAB,,FILDSK + OLT .FTYI,,.FTYI,,.FTYI,,0+VARIAB,,FILDSK + OLT .FTYO,,.FTYO,,.FTYO,,1+VARIAB,,FILDSK + OLB .GCOLL + OLB .GTLOUT,,,,,1,,GTL + OLB .HISSPEED,,,,,2,,SITS + OLT .LPLCN,,.FIXECLIMP,,,,0+VARIAB,,LSPRNT + OLB .NODES,,NODES,NODES + OLT .NODRIB,,.NONDUPLICATA,.NONDUP,,,,,FILDSK + OLT .OPENA,,.OUVREA,,,,1+VARIAB,,FILDSK + OLT .OPENM,,.OUVREM,,,,1+VARIAB,,FILDSK + OLT .OPENR,,.OUVRER,,,,1+VARIAB,,FILDSK + OLT .OPENW,,.OUVREE,,,,1+VARIAB,,FILDSK + OLB .OPTIONS + OLB .PRIMITIVES + OLB .READPALETTE,,,.REAPAL,,1,,COLOR + OLB .RUG,,RUG,RUNRUG + OLB .RXDUMP,,,RXDUMP,,0,,LSI&RXDISK + OLT .SETFILE,,.FIXEFICHIER,.FF,,,1+VARIAB,,FILDSK + OLB .SETFONT,,,,,2,,TVS + OLB .SETLINEL,,,,,1,,SITS!LSI + OLT .SETLPL,,.FIXELIMP,,,,1,,LSPRNT + OLB .SETTV,,SETTV,SETTV,,2,,TIMCLK + OLB .SGCF,,SGCF,SGCF + OLB .SPNF,,SPNF,SPNF + OLB .STATUS,,,STATUS + OLB .STF,,,SETSTF,,,,DEBUGR + OLB .TTYP,,,,,1,,MULTTY + OLB .TVHERE,,,,,1,,TVS + OLB .TVOMODE,,,,,2,,TVS + OLB .TVP,,,,,,,TVS + OLB .TVGRAB,,,TVGRAB,,1,,TVS + OLB .TYI,,TYI,DEVTYI,,1,,MULTTY + OLB .TYO,,TYO,DEVTYO,,2,,MULTTY + OLB .VERSION,,VERSION,VERSN + OLB .WRITEBLUE,,,.WRIBLUE,,2,,COLOR + OLB .WRITEGREEN,,,.WRIGREEN,,2,,COLOR + OLB .WRITEPALETTE,,,.WRIPAL,,2,,COLOR + OLB .WRITERED,,,.WRIRED,,2,,COLOR + OLE ALL,,,NOTPRO + OLT ALSO,,AUSSI,,,,,,DDF + OLB ANGLAIS,,,,,,, + OLF ARBRE,,,NOTPRO + OLB ARCTAN,ATAN,,ATAN,,1,,FPPF + OLE ARRAY,,,NOTPRO + OLE ARRAYS,,ARAYS,NOTPRO + OLT ASIZE,,DIMMAT,,ASIZEX,,1 +; OLB ATOD,,,,,1,,AI& + OLF AVEC,,,NOTPRO + OLT BACK,BK,RECULE,RE,,,1,,GTL!NPLOT!NDISP!TURFLG + OLT BELL,,DING + OLB BIGFONT,,,,,,,TVS +; OLB BITOUT,,,,,1,,AI& + OLT BLINK,,CLIGNE,,,,,,GTL + OLT BOTH,,LESDEUX,,,BAKPRI,2 +; OLB BOXIN,,,,,1,,AI& + OLT BTOUCH,,TOUCHEAR,,,,,,TURFLG + OLE BURY + OLT BUTFIRST,BF,SAUFPREMIER,SP,,,1 + OLT BUTLAST,BL,SAUFDERNIER,SD,,,1 + OLT CATCH,,ATTRAPE,,,,1+VARIAB + OLB CHANGE,,,,,2,,GTL + OLB CHAR,,,,,1 + OLT CLEARSCREEN,CS,VIDEECRAN,VE,,,,,NDISP!GTL + OLB CLIP,,,,,,,TVS + OLT CLOCK,,SECONDES,,,,,,TIMCLK + OLB CNTRL,,,,,,,DDF + OLT CONTENTS,,CONTENU + OLB CONTINUE,CO + OLB COS,,,COSF,,1,,FPPF + OLT COUNT,,COMPTE,,,,1 + OLB CRINDEX,,,.CRIND,,1,,FILDSK + OLB CTYOWAIT,,,,,1,,SITS + OLB CURSET,,,,,1,,TVS + OLB DATE,,,UDATEG,,,,TIMCLK + OLB DEBUG,,,DEBUG + OLT DEFINEARRAY,DEFAR,DEFMATRICE,DEFMAT,DEFAR,,3+VARIAB + OLT DELETE,ERF,DETRUIS,,.DELET,,1,,FILDSK + OLT DELETEINDEX,ERI,DETRUISINDEX,,.DELI,,1,,FILDSK + OLB DELTAXY,DELXY,,,,2,,GTL + OLB DIFFERENCE,,,DIFF,,2 + OLE DISPLAY,,,,,1,,NDISP!GTL + OLB DIZZY,,,,,1,,GTL + OLB DPOINT,,,,,,,GTL + OLT DUMP,,ENVOIEC,,,,,,LSIHAK + OLB ED,,,EDIT + OLT EDIT,,EDITE + OLB EDL,,,EDLINE + OLB EDT,,,EDTITL + OLT EITHER,,UNDE,,,BAKPRI,2 + OLE ELSE + OLT EMPTYP,,VIDE,,EMPTYP,,1 + OLT END,,FIN + OLF ENFOUIS,,,BURY + OLT ENDFILE,,FINFICHIER,,,,,,DMPCAS!LSIHAK + OLB ENGLISH,,,,,,, + OLT EQUAL,,EGAL,,EQUAL,,2 + OLT ERASE,ER,EFFACE,EF + OLB ERASERDOWN,ERD,,ERASED,,0,,COLOR + OLB ERASERUP,ERU,,ERASEU,,0,,COLOR +; OLB ERDOWN,ERD + OLT ERBRK,,ERARRET,,ERRBREAK + OLT ERCLR,,ERTERMINE,,ERRCLEAR + OLT ERL,,EFL + OLT ERLIN,,ERLIGNE,,ERRLINE + OLB ERLOC,,ERRLOCATION,ERRLOCATION + OLT ERNAM,,ERNOM,,ERRNAM + OLB ERNUM,,ERRNUMBER,ERRNUMBER + OLB ERPRO,,ERRPROCEDURE,ERRPROCEDURE + OLB ERRET,,RETURN,RETURN,,1 + OLT ERSET,,ERFIXE,,ERRSET + OLB ERTOK,,ERRTOKEN,ERRTOKENî +; OLB ERWINDOW,EW,,,,1+VARIAB,,TVS + OLF EXECUTE,,,DO,,1 +; OLE EYETURTLE,,,EYE,,1,,LSI-1 + OLF FICHIER,,,NOTPRO + OLE FILE,,,NOTPRO + OLT FIRST,F,PREMIER,PREM,,,1 + OLF FIXEDIR,,,SETHEA,,1,,GTL!NPLOT!NDISP + OLT FORWARD,FD,AVANCE,AV,,,1,,GTL!NPLOT!NDISP!TURFLG + OLT FPRINT,,ECRISC,,,,1+VARIAB + OLT FPUT,,INCLUSD,,,,2+VARIAB + OLB FRANCAIS,,,,,,, + OLB FRANGLAIS,,,,,,, + OLB FRENCH,,,,,,, + OLT FTOUCH,,TOUCHEAV,,,,,,TURFLG + OLT GET,,SORT,,,,2+VARIAB + OLT GO,,VA,,,,1 + OLT GOODBYE,,SALUT + OLT GREATER,,PLUSGRAND,,GREATR,,2 + OLT GTLDIS,,GTLECRAN,,,,,,GTL + OLB HALHACK,,,,,1,,HALFLG + OLB HALCROCK,,,,,1,,SITS + OLT HEADING,,CAP,,,,,, + OLT HERE,,ICI,,,,,, + OLT HIDETURTLE,HT,CACHE,,,,,,NDISP!GTL + OLB HIDEWINDOW,HW,,,,1+VARIAB,,TVS +; OLT HISSPEED,,SAVITESSE,,,,2,,DHON + OLT HOME,H,ORIGINE,ORI,,,,, + OLE IF,,,,BAKPRI,1 + OLT IFFALSE,IFF,SIFAUX,SIF + OLT IFTRUE,IFT,SIVRAI,SIV + OLT ILINE,,ILIGNE + OLB INDEX,,,NOTPRO + OLT INTEGER,INT,ENTIER,,,,1,,FPPF + OLT LAMPOFF,,ETEINT,,,,,,TURFLG!GTL + OLT LAMPON,,ALLUME,,,,,,TURFLG!GTL + OLT LAST,L,DERNIER,DER,,,1 + OLT LEFT,LT,GAUCHE,GA,,,1,,GTL!NPLOT!NDISP!TURFLG + OLT LESS,,PLUSPETIT,,LESSP,,2 + OLT LEVEL,,NIVEAU,,FLEV +; OLT LIGHT,,LUMIERE,,,,,,LSI-1 + OLF LIGNE,,,NOTPRO + OLE LINE,,,NOTPRO + OLT LINEPRINT,LP,IMPRIMANTE,IMP,LPRINT,,1+VARIAB,,> + OLT LINEPRINT,LPT,IMPRIMANTE,IMP,LPRINT,,1+VARIAB,, + OLT LIST,,LISTE,,LIST.P,,2+VARIAB + OLT LISTP,,LISTEP,,LISTP,,1 + OLT LOAD,,RAMENEC,,,,1-DMPCAS,,LSIHAK + OLB LOAD2500,,,,,2,,SITS + OLB LOCAL,,,,,1 + OLT LOGIN,,CEST,,,,1,,FILDSK + OLT LPUT,,INCLUSF,,,,2+VARIAB + OLT LTOUCH,,TOUCHEG,,,,,,TURFLG + OLT MAIL,,MALLE,,,,1,,SITS + OLT MAKE,,RELIE,,,,2 + OLB MAKEWINDOW,MW,,,,3,,TVS + OLF MATRICE,,,NOTPRO + OLF MATRICES,,MATRS,NOTPRO + OLB MCLEAR,,,,,,,MUSBOX + OLB MEDFONT,,,,,,,TVS + OLT MEMBER,,MEMBRE,,,,2 + OLB METER,,,,,1,,METERS + OLB METERGO,,,,,1,,METERS + OLT MLEN,,LONGM,,,,,,MUSBOX + OLF MONTRE,,,DISPLAY,,1,,NDISP!GTL + OLT MOVETURTLE,MOVET,BOUGE,,MOVE,,1,,GTL + OLB MUCTRL,,,,,1,,MUSBOX + OLB MULTIW,,,,,1,,LSI + OLB MUTYO,MUT,,,,2+VARIAB,,MUSBOX + OLB MUWAIT,,,,,1,,MUSBOX + OLT MYSPEED,,MAVITESSE,,,,1,,MUSBOX + OLE NAME,,,NOTPRO + OLE NAMES,,,NOTPRO + OLT NEWSNAP,,NOUVPHOTO,,,,,,NDISP + OLB NOCLIP,,,,,,,TVS + OLT NODISPLAY,ND,LIBECRAN,,KILLDISPLAY,,,,NDISP + OLT NOGTL,,SANSECRAN,,,,,,GTL + OLF NOM,,,NOTPRO + OLF NOMS,,,NOTPRO + OLT NOMUSIC,,LIBMUSIQUE,,,,,,MUSBOX + OLT NOPLOTTER,,LIBTRACEUR,,KILLPL,,,,NPLOT + OLT NOT,,NON,,,BAKPRI,1 + OLE NOTBOX,,,,,,,PTBOX + OLB NOTE,,,SING,,2+VARIAB,,MUSBOX + OLT NOTURTLE,,LIBTORTUE,,KILLTURTLE,,,,TURFLG + OLT NOWRAP,,DEBORDEPAS,,,,,,NDISP!GTL + OLT NUMBERP,,NOMBREP,,NUMBP,,1 + OLT NVOICES,,NPISTES,,,,1,,MUSBOX + OLB OSNAP,,,,,1,,GTL + OLB OUTPUT,OP,,,,1 + OLF PASAPAS,,,STEP + OLB PAUSE + OLT PENDOWN,PD,DESCENDPLUME,DP,,,,,GTL!NPLOT!NDISP!TURFLG + OLT PENP,,PLUMEP,,,,,,TVS!NDISP!GTL + OLT PENUP,PU,LEVEPLUME,LP,,,,,GTL!NPLOT!NDISP!TURFLG + OLE PLOTTER,,,STRTPL,,,,NPLOT!GTL + OLT PM,,JM,,,,,,MUSBOX + OLT POF,,IMF,,.POF,,1,,FILDSK + OLT POI,,IMI,,.POI,,,,FILDSK + OLB POINT,,,,,2+VARIAB,,TVS + OLB POINTCOLOR,,,POINTCOLOR,,2+VARIAB,,TVS + OLB POINTSTATE,PS,,,,2+VARIAB,,TVS + OLT POL,,IML + OLT POT,,IMT + OLT POTS,,IMTS + OLT PRINT,PR,ECRIS,EC,,,1+VARIAB + OLT PRINTON,,COPIE,,PRTON,,,,CPF + OLT PRINTOFF,,NONCOPIE,,PRTOFF,,,,CPF + OLT PRINTOUT,PO,IMPRIME,IM,SHOW + OLB PRINTSCREEN,PRS,,,,,,TVS + OLB PROCEDURES,,,NOTPRO + OLT PRODUCT,,PRODUIT,,PROD,,2+VARIAB + OLB QUOTIENT,,,DIVDE,,2 + OLT RANDOM,,HASARD + OLT READ,,RAMENE,,.READ,,1,,FILDSK + OLT READPTR,PTR,DECODE,,,,1+VARIAB,,SITS +; OLT RELAY,RELAIE,,,,,2,,AI& + OLT REMAINDER,MOD,RESTE,,MOD,,2 + OLT REQUEST,RQ,REPONSE,,RQUEST + OLT RIGHT,RT,DROITE,DR,,,1,,GTL!NDISP!NPLOT!TVS + OLT RTOUCH,,TOUCHED,,,,,,TURFLG + OLT RUBDIS,,ENLEVE,,,,1,,GTL + OLE RUN,,DO,DO,,1 + OLB SDIV,,,STNGDV,,2,,SARITH + OLB SEETURTLE,,,SEETURTLE,,0,,TVS + OLT SENTENCE,SE,PHRASE,PH,,,2+VARIAB + OLT SETHEADING,,METSLECAP,,,,1,, + OLT SETINDEX,SETI,FIXEINDEX,FIXEI,.DIRSE,,1,,FILDSK + OLT SETTURTLE,SETT,PLACETORTUE,,,,1,, + OLT SETX,,FIXEX,,,,1,, + OLT SETXY,,FIXEXY,,,,2,, + OLT SETY,,FIXEY,,,,1,, + OLT SHOWTURTLE,ST,POINTE,,,,,,NDISP!GTL + OLB SHOWWINDOW,SW,,,,1+VARIAB,,TVS + OLF SI,,,IF,BAKPRI,1 + OLB SIN,,,SINEF,,1,,FPPF + OLF SINON,,,ELSE + OLB SMALLFONT,,,,,,,TVS + OLB SMINUS,,,STNGMI,,2,,SARITH + OLB SMUL,,,STNGML,,2,,SARITH + OLT SNAP,,PHOTO,,,,,,NDISP!GTL + OLB SPIN,,,,,1,,GTL + OLB SPLUS,,,STNGPL,,2,,SARITH + OLT SQRT,,RCAR,,,,1,,FPPF + OLT STARTDISPLAY,SD,ECRAN,,,,1,,NDISP + OLE STEP,,.STEP + OLB STOP + OLF STOPPE,,,STOP + OLB STORE,,,,,3+VARIAB + OLT SUM,,SOMME,,,,2+VARIAB +; OLB SWITCH,,,,,2,,AI& + OLB TABLET,,,,,4,,LSI + OLE TBOX,,,,,,,PTBOX + OLT TEST,,TESTE,,,BAKPRI,1 + OLT TEXT,,TEXTE,,TEXTT,,1 + OLT THEN,,ALORS + OLT THING,,CHOSE,,DOTS,,1 + OLT THINGP,,CHOSEP,,,,1 + OLT THROW,,LANCE,,,,0+VARIAB + OLT TIME,,HEURE,,UTIMEG,,,,TIMCLK + OLE TITLE,,,NOTPRO + OLE TITLES,,TITLS,NOTPRO + OLF TITRE,,,NOTPRO + OLF TITRES,,TITRS,NOTPRO + OLT TO,,POUR + OLT TOOT,,BEEP,,,,1,,TURFLG + OLT TOPLEVEL,,NIVEAUSUP,,TOPLEVEL + OLF TORTUE,,,STARTT,,,,TURFLG!GTL + OLF TOUT,,,NOTPRO + OLB TRACE + OLF TRACEUR,,TRAC,STRTPL,,,,NPLOT + OLE TREE,,,NOTPRO + OLB TRIANGLETURTLE,,,,,,,TVS + OLB TTYP,,,,,,,SITS!LSI + OLE TURTLE,,STTUR,STARTT,,,,TURFLG!GTL + OLB TURTLESIZE,,,TRSIZE,,1,,TVS + OLB TVHERE,,,,,,,TVS + OLB TVSIZE,,,RESIZE,,1+VARIAB,,TVS + OLB TVOMODE,,,,,1,,TVS + OLB TYOWAIT,,,,,2,,SITS + OLT TYPE,,TAPE,,,,1+VARIAB + OLT TYPEIN,,PREPONSE + OLT UNTIL,,JUSQUACEQUE,JQ,,BAKPRI,1 +.IFZ UNIX + OLT USE,,REFERE,,.USE,,1,,FILDSK +.ENDC + OLB USEDISPLAY,,,,,,,GTL + OLB USING,,,NOTPRO + OLT UNMOUNT,,DEMONTE,,,,1,,FILDSK&LSI + OLT VLEN,,LONGP,,,,,,MUSBOX + OLT VOICE,,PISTE,,,,1,,MUSBOX + OLT WAIT,,ATTENDS,,UWAIT,,1,,TIMCLK + OLT WHERE,,OU + OLT WIPE,,DEGAGE,,,,1,,NDISP + OLT WIPECLEAN,WC,BALAYE,,,,,,NDISP!GTL + OLT WORD,,MOT,,,,2+VARIAB + OLT WORDP,,MOTP,,WORDP,,1 + OLT WRAP,,DEBORDE,DEB,,,,,NDISP!GTL + OLT WRITE,,ENVOIE,,.WRITE,,1,,FILDSK + OLT WRITEPTP,PTP,PERFORE,,,,1+VARIAB,,SITS + OLB XCOR,,,,,,, + OLB XORDOWN,XD,,,,,,TVS + OLB XORUP,XU,,,,,,TVS + OLB XORWINDOW,XW,,,,1+VARIAB,,TVS + OLB YCOR,,,,,,, + +.IF NDF PASS2 +DC NUMNSC,NUMOBS ;NUMBER OF NON-SPECIAL CHARACTER OBLIST ELEMENTS + .ENDC + OLB ^\!(\,,LLPAR,LLPAR,PARPRI,1 + CDM EXCL$ + OLB ^\;\,^\!\,COMT,COMT,HIPRI + CDM HASH$ + OLB ^\#\,,PROC,PROC,HIPRI,1 + CDM LP$ + OLB ^\(\,,LPAR,LPAR,PARPRI,1 + CDM RP$ + OLB ^\)\,,RPAR,RPAR,PARPRI + CDM PRD$ + OLB ^\*\,,STAR,PROD,MDPRI,2+VARIABLE,YINFIX + CDM PLU$ + OLB ^\+\,,PLUS,SUM,PMPRI,2+VARIABLE,YINFIX + OLB ^\++\,,UPLUS,UPLUS,HIPRI,1 + CDM MIN$ + OLB ^\-\,,MINUS,DIFF,PMPRI,2,YINFIX + OLB ^\--\,,UMINS,UMINS,HIPRI,1 + CDM DIV$ + OLB ^\/\,,SLSH,DIVDE,MDPRI,2,YINFIX + CDM DOTS$ + OLB ^\:\,,DOTS,DOTS,HIPRI,1 + CDM LSS$ + OLB ^\<\,,LESS,LESS,RELPRI,2,YINFIX + CDM EQL$ + OLB ^\=\,,EQUAL,EQUAL,RELPRI,2,YINFIX + CDM GTR$ + OLB ^\>\,,GRTR,GREATR,RELPRI,2,YINFIX + CDM BKSL$ + OLB ^/\/,,BKSL,MOD,MDPRI,2,YINFIX + CDM BKAR$ + OLB ^/_/,,BKAR,MAKE,BAKPRI,2,YINFIX + + +.IF NDF PASS2 +.=.+ +.IFF +.=OBADD2 +.ENDC + + +DC .VERR,-128. +DC .VRTS,-128. +GCMKL: TOPS + TOPS1 + TOPS2 + GCP1 + GCP2 + GCPREV +.IF NZ MUSBOX + MVOC + MVOC+2 + MVOC+4 + MVOC+6 +.ENDC + ILINEL ;PTR TO TYPED INPUT LINE + ERPROC ;PTR TO ERRSET PROC + .IIF NZ NDISP, SNLIST + 0 + + +SECRET: .ASCIZ /SECRET/ +.EVEN + + .SBTTL GARBAGE COLLECTOR MARK-NODE TABLES + +BMT: .BYTE 1,2,4,10,20,40,100,200 +LMT: MARKV2 ;SYSTEM FUNCTION + MARKV2 ;INFIX (SYSTEM FUNCTION) + MKATOM ;USER FUNCTION + MKATOM ;VARIABLE BINDING + GCDIE ;IDLE NODE + GCDIE ;UNUSED + GCDIE ;BUCKET ELEMENT + MARKV2 ;SHORT STRING + .IFNZ NDISP + MKSNAP ;SNAP + .ENDC + .IFZ NDISP + GCDIE + .ENDC + MKATOM ;ATOM + MARKV2 ;SHORT NUMBER + MKINUM ;INTEGER NUMBEB + MKLIST ;LONG STRING +.IFZ FPPF + GCDIE ;TBA +.IFF + MKINUM +.ENDC + GCDIE ;UNUSED (WAS "SENTENCE" ONCE) + MKLIST ;LIST + + .SBTTL OTHER TABLES + +;THE DISPATCH TABLE FOR CONVERT + +CNVTBL: + .BYTE CNVNOP ;SNAP TO SNAP +REPT1 7,^\.BYTE 0\ ;NOT USED AT THIS TIME + +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + .BYTE 0 ;ATOM TO SNUM + .BYTE 0 ;ATOM TO INUM + .BYTE CA2LS ;ATOM TO LSTR +REPT1 3,^\.BYTE 0\ ;NOT USED AT THIS TIME + +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + .BYTE CNVNOP ;SNUM TO SNUM + .BYTE CSN2IN ;SNUM TO INUM + .BYTE CSN2LS ;SNUM TO LSTR +.IIF NZ FPPF, .BYTE CSN2FN ;SNUM TO FNUM +.IIF Z FPPF, .BYTE 0 +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + .BYTE CIN2SN ;INUM TO SNUM + .BYTE CNVNOP ;INUM TO INUM + .BYTE CIN2LS ;INUM TO LSTR +.IIF NZ FPPF, .BYTE CIN2FN ;INUM TO FNUM +.IIF Z FPPF, .BYTE 0 +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + .BYTE CLS2SN ;LSTR TO SNUM + .BYTE CLS2IN ;LSTR TO INUM + .BYTE CNVNOP ;LSTR TO LSTR +.IIF NZ FPPF, .BYTE CLS2FN ;LSTR TO FNUM +.IIF Z FPPF, .BYTE 0 +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + +.IFNZ FPPF + +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME (RNUM TO ANYTHING) + .BYTE CFN2SN ;FNUM TO SNUM + .BYTE CFN2IN ;FNUM TO INUM + .BYTE CFN2LS ;FNUM TO LSTR + .BYTE CNVNOP ;FNUM TO FNUM +REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME + + +.IFF + +REPT1 8.,^\.BYTE 0\ + + +.ENDC + +REPT1 6,^\.BYTE 0\ ;NOT USED AT THIS TIME + .BYTE CNVNOP ;SENT TO SENT +REPT1 1,^\.BYTE 0\ ;NOT USED AT THIS TIME + +REPT1 7,^\.BYTE 0\ ;NOT USED AT THIS TIME + .BYTE CNVNOP ;LIST TO LIST + +.IIF NZ .-CNVTBL-100,.PRINT /CONVERT TAB SCREWED UP!/ + .EVEN + + ;MUSIC BOX CHARACTERS + + DC MBTRAP,43 ;TRAP CHARACTER + DC MBFCH,100 ;SHUT-UP CHARACTER + DC MBREST,40 ;REST CHARACTER FOR MUSIC BOX + DC MBPERC,42 ;HIGHEST CODED PERCUSSION EFFECT + +MBVCH: .BYTE 123,42,61,60 ;CTL CHARACTERS FOR NUMBER OF VOICES +MBSCH: .BYTE 103,102,101,100 ;LIKE MBVCH, EXCEPT SPECIFIES SILENCE + + +STURF: .BYTE 162,36.,68.,19. ;TURTLE FUDGE FACTORS FOR LEFT AND RIGHT +; MULTIPLY BY EVEN BYTE AND DIVIDE BY ODD BYTE + .IFZ FPPF + +;BEAUTIFUL SINE TABLE IN WHOOPIE FORMAT + + +SIN: + + 0 ;0 DEGREES + 2167 ;2 DEGREES + 4355 ;4 DEGREES + 6541 ;6 DEGREES + 10720 ;8 DEGREES + 13072 ;10 DEGREES + 15234 ;12 DEGREES + 17367 ;14 DEGREES + 21510 ;16 DEGREES + 23615 ;18 DEGREES + 25707 ;20 DEGREES + 27763 ;22 DEGREES + 32017 ;24 DEGREES + 34034 ;26 DEGREES + 36027 ;28 DEGREES + 40000 ;30 DEGREES + 41724 ;32 DEGREES + 43623 ;34 DEGREES + 45474 ;36 DEGREES + 47315 ;38 DEGREES + 51106 ;40 DEGREES + 52646 ;42 DEGREES + 54352 ;44 DEGREES + 56023 ;46 DEGREES + 57437 ;48 DEGREES + 61015 ;50 DEGREES + 62335 ;52 DEGREES + 63615 ;54 DEGREES + 65035 ;56 DEGREES + 66214 ;58 DEGREES + 67331 ;60 DEGREES + 70404 ;62 DEGREES + 71413 ;64 DEGREES + 72357 ;66 DEGREES + 73255 ;68 DEGREES + 74107 ;70 DEGREES + 74674 ;72 DEGREES + 75412 ;74 DEGREES + 76062 ;76 DEGREES + 76463 ;78 DEGREES + 77016 ;80 DEGREES + 77301 ;82 DEGREES + 77514 ;84 DEGREES + 77660 ;86 DEGREES + 77754 ;88 DEGREES + 77777 ;90 DEGREES +.ENDC + +;PRINTOUT DISPATCH TABLE +.MACRO DT A,B +$'A +B +.ENDM +PODISP: +.IIF NZ FILDSK, DT INDEX,.POI + DT PROCED,SHALPR +.IFNZ ENG + DT ALL,SHOWAL +.IIF NZ FILDSK, DT FILE,.POFILE + DT TITLE,POT + DT TITLS,POTS + DT LINE,POL + DT ARRAY,PO1AR + DT ARAYS,POARR + DT NAMES,SHALNA +.IIF NZ FILDSK, DT TREE,.POTREE +.ENDC +.IFNZ FR + DT TOUT,SHOWAL +.IIF NZ FILDSK, DT FICHIER,.POFILE + DT TITRE,POT + DT TITRS,POTS + DT LIGNE,POL + DT MATRICE,PO1AR + DT MATRS,POARR + DT NOMS,SHALNA +.IIF NZ FILDSK, DT ARBRE,.POTREE +.ENDC + 0 + +;ERASE DISPATCH TABLE +ERSDISP: DT TRACE,ETRACE +.IIF NZ FILDSK, DT INDEX,ERINDX + DT PROCE,ERALPR +.IFNZ ENG + DT ALL,ERALL + DT .STEP,ESTEP + DT BURY,EBURY +.IIF NZ FILDSK, DT FILE,ERFI + DT LINE,ERLINE + DT NAMES,ERALNA + DT NAME,ERNAME + DT ARRAY,ERARAY + DT ARAYS,ERARAS +.ENDC +.IFNZ FR + DT TOUT,ERALL + DT PASAPAS,ESTEP + DT ENFOUI,EBURY +.IIF NZ FILDSK, DT FICHIER,ERFI + DT LIGNE,ERLINE + DT NOMS,ERALNA + DT NOM,ERNAME + DT MATRICE,ERARAY + DT MATRS,ERARAS +.ENDC + 0 + ;DISPLAY DIRECTION CODES + +DREC: .BYTE 10 + .BYTE 0 + .BYTE 20 + .BYTE 30 + .BYTE 60 + .BYTE 70 + .BYTE 50 + .BYTE 40 + .EVEN + .SBTTL SYSTEM DISPATCH TABLE (BYTE ONE) + +;FLAG DEFINITIONS +DC FSF,200 ;SPECIAL INPUT +DC FOF,100 ;SPECIAL OUTPUT +DC FQF,20 ;QUOTING +DC SEPF,4 ;SEPARATOR +DC WSF,2 ;WORD SEPARATOR +DC NNUMF,40 ;NOT A NUMBER +DC OPERF,10 ;OPERATOR + +DTBL: +.BYTE NNUMF,FOF!NNUMF ;^@ ;^A ECHOES AS CR +.BYTE FSF!NNUMF,FSF!NNUMF ;^B IS CONVERTED TO % + ;^C COPYS NEXT CHARACTER +.BYTE FSF!NNUMF,NNUMF ;^D DELETES NEXT CHARACTER ;^E +.BYTE NNUMF,FSF!FOF!NNUMF ;^F ;^G BREAK +.BYTE FOF!NNUMF,FOF!SEPF!WSF!NNUMF ;^H BACKSPACE ;^I TABULATE +.BYTE FOF!SEPF!WSF!NNUMF,FOF!SEPF!WSF!NNUMF ;^J LINE FEED + ;^K TABULATE VERTICALLY +.BYTE FOF!SEPF!WSF!NNUMF,FSF!FOF!SEPF!WSF!NNUMF ;^L FORM FEED + ;^M CARRIAGE RETURN ECHOES AS CRLF +.BYTE FSF!NNUMF,NNUMF ;^N GET NEXT WORD ;^O +.BYTE NNUMF,FSF!NNUMF ;^P ;^Q SUPER-QUOTE +.BYTE FSF!NNUMF,FSF!NNUMF ;^R COPY REST OF LINE + ;^S SKIP NEXT WORD +.BYTE NNUMF,NNUMF ;^T ;^U +.BYTE NNUMF,FSF!NNUMF ;^V ;^W ERASE LAST WORD +.BYTE FSF!NNUMF,FSF!NNUMF ;^X CLARIFY INPUT + ;^Y EDIT PREVIOUS LINE +.BYTE FSF!NNUMF,NNUMF ;^Z DESTROY INPUT BUFFER + ;^[ MAYBE ALTMODE +.BYTE NNUMF,NNUMF ;^\ ;^] +.BYTE NNUMF,NNUMF ;^^ ;^_ ANY BETTER IDEAS FOR THEM? +.BYTE SEPF!WSF!NNUMF,NNUMF!SEPF!OPERF ;SP ;! COMMENT? +.BYTE SEPF!NNUMF,SEPF!NNUMF!OPERF ;" ;# ACTION OF +.BYTE NNUMF,NNUMF ;$ ;% +.BYTE NNUMF,NNUMF!OPERF ;& ;' (MAYBE LE) +.BYTE SEPF!NNUMF!OPERF,SEPF!NNUMF!OPERF ;( ARITHMETIC GROUPING + ;) DITTO +.BYTE SEPF!NNUMF!OPERF,SEPF!NNUMF!OPERF ;* MULTIPLY ;+ ADD +.BYTE NNUMF,SEPF!NNUMF!OPERF ;, ;- SUBTRACT +.IIF NZ FPPF, .BYTE 0,SEPF!NNUMF!OPERF +.IIF Z FPPF, .BYTE NNUMF,SEPF!NNUMF!OPERF ;. ;/ DIVIDE +.BYTE 0,0 ;0 ;1 +.BYTE 0,0 ;2 ;3 +.BYTE 0,0 ;4 ;5 +.BYTE 0,0 ;6 ;7 +.BYTE 0,0 ;8. ;9. +.BYTE SEPF!NNUMF!OPERF,SEPF!NNUMF!OPERF ;: THING OF ;; PROPERTY OF +.BYTE SEPF!NNUMF!OPERF,SEPF!NNUMF!OPERF ;< ;= +.BYTE SEPF!NNUMF!OPERF,NNUMF ;> ;? +.BYTE NNUMF,NNUMF ;@ ;A +.BYTE NNUMF,NNUMF ;B ;C +.IIF NZ FPPF, .BYTE NNUMF,0 +.IIF Z FPPF, .BYTE NNUMF,NNUMF ;D ;E +.BYTE NNUMF,NNUMF ;F ;G +.BYTE NNUMF,NNUMF ;H ;I +.BYTE NNUMF,NNUMF ;J ;K +.BYTE NNUMF,NNUMF ;L ;M +.IIF NZ FPPF, .BYTE 0,NNUMF +.IIF Z FPPF, .BYTE NNUMF,NNUMF ;N ;O +.BYTE NNUMF,NNUMF ;P ;Q +.BYTE NNUMF,NNUMF ;R ;S +.BYTE NNUMF,NNUMF ;T ;U +.BYTE NNUMF,NNUMF ;V ;W +.BYTE NNUMF,NNUMF ;X ;Y +.BYTE NNUMF,FSF!FQF!SEPF!WSF!NNUMF ;Z ;[ +.BYTE SEPF!NNUMF!OPERF,FSF!FQF!SEPF!WSF!NNUMF ;\ MODULO ;] +.BYTE SEPF!NNUMF,SEPF!NNUMF!OPERF ;^ EXPONENTIATE, MAYBE + ;_ MAKE + .BYTE NNUMF,NNUMF ;` GRAVE ACCENT ;a LOWER CASE +.BYTE NNUMF,NNUMF ;b LOWER CASE ;c LOWER CASE +.BYTE NNUMF,NNUMF ;d LOWER CASE ;e LOWER CASE +.BYTE NNUMF,NNUMF ;f LOWER CASE ;g LOWER CASE +.BYTE NNUMF,NNUMF ;h LOWER CASE ;i LOWER CASE +.BYTE NNUMF,NNUMF ;j LOWER CASE ;k LOWER CASE +.BYTE NNUMF,NNUMF ;l LOWER CASE ;m LOWER CASE +.BYTE NNUMF,NNUMF ;n LOWER CASE ;o LOWER CASE +.BYTE NNUMF,NNUMF ;p LOWER CASE ;q LOWER CASE +.BYTE NNUMF,NNUMF ;r LOWER CASE ;s LOWER CASE +.BYTE NNUMF,NNUMF ;t LOWER CASE ;u LOWER CASE +.BYTE NNUMF,NNUMF ;v LOWER CASE ;w LOWER CASE +.BYTE NNUMF,NNUMF ;x LOWER CASE ;y LOWER CASE +.BYTE NNUMF,FSF!FQF!SEPF!WSF!NNUMF ;Z LOWER CASE ;LEFT BRACE +.BYTE NNUMF,FSF!FQF!SEPF!WSF!NNUMF ;VERTICAL BAR ;RIGHT BRACE +.BYTE NNUMF,FSF!NNUMF ;TILDE ;RUBOUT + .SBTTLE SYSTEM DISPATCH TABLE (BYTE TWO) +;NUMBERS POINT TO OTHER TABLES +;$ POINTS TO SYSTEM OBLIST + +DTBL2: +.BYTE 0,0 ;^@ ;^A +.BYTE 36,0 ;^B BECOMES %, PRINTS AS SPACE IN STRINGS + ;^C COPY NEXT CHARACTER +.BYTE 2,0 ;^D DELETES NEXT CHAR ;^E +.BYTE 0,4 ;^F ;^G BREAK +.BYTE 2,10 ;^H BACKSPACE ;^I TABULATE +.BYTE 12,14 ;^J LINE FEED ;^K TABULATE VERTICALLY +.BYTE 16,6 ;^L FORM FEED + ;^M CARRIAGE RETURN ECHOES AS CRLF +.BYTE 10,0 ;^N GET NEXT WORD ;^O +.BYTE 0,12 ;^P ;^Q SUPER-QUOTE +.BYTE 14,16 ;^R ;^S SKIP NEXT WORD +.BYTE 0,0 ;^T ;^U +.BYTE 0,20 ;^V ;^W ERASE LAST WORD +.BYTE 22,24 ;^X CLARIFY INPUT ;^Y +.BYTE 26,0 ;^Z DESTROY INPUT BUFFER + ;^[ MAYBE ALTMODE +.BYTE 0,0 ;^\ ;^] +.BYTE 0,0 ;^^ ;^_ WELL, ANY BETTER IDEAS FOR THEM? +.BYTE 0,EXCL$ ;SP ;! COMMENT? +.BYTE 0,HASH$ ;" ;# ACTION OF +.BYTE 0,0 ;$ ;% +.BYTE 0,0 ;& ;' (MAYBE LE) +.BYTE LP$,RP$ ;( ARITHMETIC GROUPING ;) DITTO +.BYTE PRD$,PLU$ ;* MULTIPLY ;+ ADD +.BYTE 0,MIN$ ;, ;- SUBTRACT +.BYTE 0,DIV$ ;. ;/ DIVIDE +.BYTE 0,0 ;0 ;1 +.BYTE 0,0 ;2 ;3 +.BYTE 0,0 ;4 ;5 +.BYTE 0,0 ;6 ;7 +.BYTE 0,0 ;8. ;9. +.BYTE DOTS$,EXCL$ ;: THING OF ;; PROPERTY OF +.BYTE LSS$,EQL$ ;< ;= +.BYTE GTR$,0 ;> ;? +.BYTE 0,0 ;@ ;A +.BYTE 0,0 ;B ;C +.BYTE 0,0 ;D ;E +.BYTE 0,0 ;F ;G +.BYTE 0,0 ;H ;I +.BYTE 0,0 ;J ;K +.BYTE 0,0 ;L ;M +.BYTE 0,0 ;N ;O +.BYTE 0,0 ;P ;Q +.BYTE 0,0 ;R ;S +.BYTE 0,0 ;T ;U +.BYTE 0,0 ;V ;W +.BYTE 0,0 ;X ;Y +.BYTE 0,32 ;Z ;[ +.BYTE BKSL$,34 ;\ MODULO ;] +.BYTE 0,BKAR$ ;^ (MAYBE EXPONENTIATE) ;_ MAKE +.BYTE 0,0 ;` GRAVE ACCENT ;a LOWER CASE +.BYTE 0,0 ;b LOWER CASE ;c LOWER CASE +.BYTE 0,0 ;d LOWER CASE ;e LOWER CASE +.BYTE 0,0 ;f LOWER CASE ;g LOWER CASE +.BYTE 0,0 ;h LOWER CASE ;i LOWER CASE +.BYTE 0,0 ;j LOWER CASE ;k LOWER CASE +.BYTE 0,0 ;l LOWER CASE ;m LOWER CASE +.BYTE 0,0 ;n LOWER CASE ;o LOWER CASE +.BYTE 0,0 ;p LOWER CASE ;q LOWER CASE +.BYTE 0,0 ;r LOWER CASE ;s LOWER CASE +.BYTE 0,0 ;t LOWER CASE ;u LOWER CASE +.BYTE 0,0 ;v LOWER CASE ;w LOWER CASE +.BYTE 0,0 ;x LOWER CASE ;y LOWER CASE +.BYTE 0,32 ;z LOWER CASE ;{ OPEN BRACE +.BYTE 0,34 ;| VERTICAL BAR, MAYBE OR, MAYBE XOR + ;} CLOSE BRACE +.BYTE 0,30 ;~ TILDE, LOGICAL NOT ;RBO RUBOUT + +DC LPURBL,<<.-PURAD>_-10.> +.IIF GT .-PURAD-20000,.ERROR OOOPS!! TOO MUCH PURE STUFF! diff --git a/src/nlogo/sitss.3 b/src/nlogo/sitss.3 new file mode 100755 index 00000000..0eacc8d6 --- /dev/null +++ b/src/nlogo/sitss.3 @@ -0,0 +1,2 @@ +.INSRT SITS;SITSS SYMS +.IIF NZ UNIX, .INSRT NOSITS > diff --git a/src/nlogo/slogo.cmd b/src/nlogo/slogo.cmd new file mode 100755 index 00000000..68deb993 --- /dev/null +++ b/src/nlogo/slogo.cmd @@ -0,0 +1 @@ +/H/H/ENLOGO;COMMON,SITSS,INIT,IGGL,IMPURE,PURE,EVAL,STORAG,DISPLAY,GTFUN,FILING,CONTRO diff --git a/src/nlogo/storag.15 b/src/nlogo/storag.15 new file mode 100755 index 00000000..9574f364 --- /dev/null +++ b/src/nlogo/storag.15 @@ -0,0 +1,773 @@ +.GLOBL AFREE,AROVER,ASPACE,BKPTR,SIZE ;005 +;FORMAT OF ARRAY HEADER IS: +; WORD 0 BACK POINTER TO ATOM BOUND TO THIS ARRAY +; WORD 1 LENGTH OF STORAGE USED +; WORD 2 TYPE (INUM, FNUM OR 0 FOR POINTER) + NUMBER OF DIMENSIONS +; WORD 3 DIMENSION 3 +; WORD 4 DIMENSION 2 +; WORD 5 DIMENSION 1 +; WORDS 6,7,10 AND 11 ARE USED ONLY FOR WINDOWS +;A FREE ARRAY BLOCKS: +; WORD 0 POINTER TO NEXT FREE BLOCK +; WORD 1 LENGHT OF BLOCK +; WORD 2 BACK POINTER TO PREVIOUS FREE BLOCK + + + ;INPUT--B HAS SIZE OF BLOCK TO BE ALLOCATED IN BYTES + ;OUTPUT--A HAS PTR.TO BLOCK IF ALLOCATION SUCESSFUL + ; SECOND WORD OF BLOCK CONTAINS SIZE OF BLOCK IN BYTES + ; AND SKIP RETURN + + +..ALLO: CMP B,ASPACE ;SIZE OF ARRAY .LE. FREE SPACE? + BGT ARREXP ;NO, TRY TO EXPAND + PUSH C + MOV AROVER,A ;GET FRE BLOCK PTR. +SRCBLK: CMP B,SIZE(A) ;IS BLOCK NOW POINTED AT BIG ENOUGH? + BLE OKALOC ;YES + CMP (A),AROVER ;CHAIN GONE THRU' ONCE? + BEQ CMPRES ;YES + MOV (A),A ;NEXT FREE BLOCK + BNE SRCBLK ;LAST BLOCK IN CHAIN? + MOV AFREE,A ;YES,START FROM THE BEGINNING + CMP A,AROVER + BNE SRCBLK + +CMPRES: JSR PC,.PRESS ;GO COMPRESS THE ARRAY SPACE +.IFNZ LSI + CMP B,ASPACE ;SPACE COULD HAVE SHRUNK DURING A .PRESS + BLE 1$ ;STILL ROOM + SPOP C + BR ARREXP ;EXPAND ARRAY SPACE, SIGH.... +1$: +.ENDC + MOV AROVER,A ;A POINTS TO FREE SPACE +OKALOC: MOV SIZE(A),C + SUB B,C + CMP #HEADER+4,C + BGE HOLE + MOV A,C ;TO ADDR.OF FREE BLOCK + ADD B,C ;ADD SIZE OF ALLOCATED BLOCK TO GET NEW FREE BLOCK ADDR. + SUB B,SIZE(A) ;GET SIZE OF NEW FREE BLOCK + MOV SIZE(A),SIZE(C) ;AND STORE IN SIZE FIELD OF NEW FREE BLOCK + MOV B,SIZE(A) + MOV BKPTR(A),BKPTR(C) ;PTR. MANAGEMENT + BEQ NEWBK1 ;IF THIS BLOCK FIRST OF CHAIN,SKIP + MOV C,@BKPTR(A) ;CHANGE FORWARD PTR. OF LAST BLOCK +NEWBK1: MOV (A),(C) ;FORWARD PTR. FOR NEW BLOCK + BEQ NEWBK3 ;IF THIS BLOCK IS LAST IN CHAIN,SKIP +NEWBK2: ADD #BKPTR,(A) ;TO ACCESS BKPTR FIELD OF NEXT BLOCK + MOV C,@(A) ;AND CHANGE IT +NEWBK3: MOV C,AROVER ;UPDATE FREE BLOCK ROVING POINTER + CMP AFREE,A ;REQUIRED TO UPDATE AFREE? + BNE ALDONE ;NO + MOV C,AFREE ;YES +ALDONE: SUB SIZE(A),ASPACE ;UPDATE FREE SPACE AVAILABLE + POP C + CLZ + RTS PC + +.GLOBL ARRHPG,ARTOP,EXSPAC ;006 +HOLE: MOV BKPTR(A),C ;TO LINK UP WITH BLOCK BEFORE THE ONE ALLOCATED + BNE NEWBK1 + MOV (A),C ;MAKE THIS THE FIRST BLOCK + CLR BKPTR(C) ;AND DONT HAVE IT HAVE A BACKPOINTER + BR NEWBK3 + +.IF NZ SITS + +ARREXP: MOV ASPACE,A ;AMOUNT OF FREE SPACE WE KNOW ABOUT + ADD #_13.+ARYAD,A ;TOTAL POSSIBLE ARRAY SPACE + SUB ARTOP,A ;AMOUNT ALREADY GOBBLED + CMP B,A ;NOW THEN, IS THIS POTENTIALLY ENOUGH?? + BLE ARREX4 + BR ARREX1 +ARREX3: ADD #6,P +ARREX1: SEZ ;TOO GREEDY + RTS PC +ARREX4: MOV B,A ;AMOUNT WE WANT + SUB ASPACE,A ;AMOUNT WE HAVE + ASH #-10.,A ;AMOUNT WE NEED IN 512 WORD BLOCKS + SAVE +ARREX2: MOV #ARRHPG,A + JSR PC,EXSPAC ;TRY TO EXPAND ARRAYS + BEQ ARREX3 ;NO LUCK + MOV ARTOP,B ;OLD TOP OF ARRAYS + ADD #2000,ARTOP ;NEW! + MOV #2000,SIZE(B) ;SIZE OF "ARRAY" WE ARE "FREEING" + JSR PC,.RELES ;FREE THE NEW SPACE + DEC (P) ;IS THAT ENOUGH? + BGE ARREX2 ;NOT YET + REST + BR ..ALLOC ;TRY IT AGAIN (THIS TIME SURE TO WIN!) + +.IFF + +ARREXP: MOV ARTOP,A ;TOP OF ARRAY SPACE + SAVE B + DEC B ;XFORM B TO LEAST NUMBER OF + BIC #1777,B ; 2000-BYTE BLOCKS >OR= B + ADD #2000,B + ADD B,A ;EXTEND ARRAY TOP + CMP A,PPDTOP ;BUMP INTO PDL SPACE? + BHI ARREXF + MOV ARTOP,B ;SAVE OLD ARTOP + MOV A,ARTOP ; AND MAKE NEW ONE + SUB B,A ;DIFFERENCE IS SIZE OF NEW SPACE + MOV A,SIZE(B) ;WHICH IS SIZE OF "ARRAY" WE ARE "FREEING" + JSR PC,.RELS1 ;FREE THE NEW SPACE + REST B + BR ..ALLOC ;SUCCEED, RETURN TO ..ALLOC +ARREXF: REST B + SEZ ;SIGNAL LOSS, FLUNK OUT OF ..ALLOC + RTS PC +.ENDC + ;RELEASE A BLOCK IN THE ARRAY SPACE + ;INPUT--B HAS PHYSICAL PTR TO BLOCK TO BE RELEASED + ;OUTPUT--B UNCHANGED. RELEASED BLOCK INSERTED INTO CHAIN OF FREE BLOCKS +.GLOBL BAT,LIMIT,NAS,WDIM ;010 + +.IF NZ SITS +.RELES: +.IFF +.RELES: JSR PC,.RELS1 + CMP ASPACE,#2000 ;MORE THAN 512 WORDS? + BLO 1$ ;NOPE + JSR PC,.PRESS +1$: RTS PC +.RELS1: +.ENDC + ADD SIZE(B),ASPACE ;UPDATE ASPACE + TST AFREE ;IS ARRAY SPACE EMPTY? + BEQ ONEBLK ;YES + PUSH A + SPUSH C + SPUSH D + MOV AROVER,C + CMP B,C ;ADDR OF RELEASED BLOCK > (AROVER) + BHI CHAIN ;START TRYING TO INSERT AT AROVER + MOV AFREE,C ;OTHERWISE START AT AFREE + CMP B,C + BHI CHAIN + MOV C,A ;SAVE POINTER TO THE OLD FIRST FREE BLOCK + JSR PC,ONEBLK ;MAKE THE THE BLOCK WE ARE FREEING, FIRST + MOV B,C ;GET POINTER TO THE END OF THIS BLOCK + ADD SIZE(B),C + CMP A,C ;IS IT THE SAME AS THE OLD AFREE? + BNE .RELE1 ;NO + ADD SIZE(C),SIZE(B) ;HERE COMPRESS THE TWO BLOCK + MOV (C),C ;GET POINTER TO NEXT BLOCK + MOV C,(B) ;FIX THIS BLOCK TO POINT TO IT + BR REDON1 ;UPDATE THE BACK POINTER OF IT IF NEEDED +.RELE1: MOV A,(B) + MOV B,BKPTR(A) + BR REDONE + +CHAIN: MOV C,A ;A_CURRENT FREE BLOCK + MOV (A),C ;C_NEXT FREE BLOCK + BEQ LSTBLK ;CURRENT BLOCK IS LAST IN CHAIN + CMP C,B ;ADDR OF NEXT FREE > ADDR OF RELEASED? + BLO CHAIN ;NO,TRY NEXT ONE + MOV SIZE(B),D ;YES,START INSERTING THE RELEASED BLOCK + ADD B,D ;SIZE IN BYTESADDED TO (B) GIVES END OF RELEASED BLOCK + CMP C,D ;WHICH MIGHT BE ADJACENT TO NEXT FREE BLK + BNE LSTBLK ;NO + ADD SIZE(C),SIZE(B) ;YES,COLLAPSE THE TWO + CMP C,AROVER ;IS AROVER POINTING TO THIS BLOCK? + BNE 1$ ;NO + MOV B,AROVER ;WELL, NOW B IS THE AROVER +1$: MOV (C),C ;UPDATE FWDPTR + +LSTBLK: MOV SIZE(A),D ;THIS FREE BLOCK + ADD A,D ;MIGHT BE ADJACENT TO THE + CMP D,B ;RELEASED BLOCK + BEQ CONBLK ;YES + MOV C,(B) ;NO,JUST UPDATE PTR + MOV A,BKPTR(B) ;SIZE FIELD NEED NOT BE CHANGED + MOV B,(A) +REDON1: TST C ;IF THIS FREE BLOCK IS LAST IN CHAIN + BEQ REDONE ;THEN NOTHING + MOV B,BKPTR(C) ;ELSE UPDATE BKPTR OF NEXT BLK +REDONE: POP D + SPOP C + SPOP A + RTS PC + +ONEBLK: MOV B,AFREE ;RELEASED BLOCK IS THE ONLY FREE ONE + MOV B,AROVER + CLR (B) + CLR BKPTR(B) + RTS PC + +CONBLK: ADD SIZE(B),SIZE(A) ;COLLAPSE + MOV C,(A) ;AND UPDATE PTR + MOV A,BKPTR(C) ;UPDATE IT'S BACK POINTER + CMP B,AROVER ;DID AROVER POINT TO THE BLOCK WE COMPRESSED? + BNE REDONE ;NO + MOV A,AROVER ;WELL, MAKE AROVER POINT TO THE START FO THE BLOCK + BR REDONE + + ;THIS ROUTINE COMPRESS THE ARRAY SPACE BY STACKING FREE BLOCKS TOGETHER + ;AFREE POINTS TO FIRST FREE BLOCK IN THE CHAIN + ;FIRST WORD OF USED BLOCK MUST CONTAIN PTR. TO WORD POINTING TO THAT BLOCK FOR RELOCATING +.GLOBL TMPBLK ;011 +.PRESS: TST AFREE ;ANY FREE SPACE? + BNE 1$ ;YES + RTS PC ;OH WELL.... +1$: PUSH A + SPUSH B + SPUSH C + SPUSH D ;SAVE AC'S + MOV AFREE,B ;B POINTS TO WHERE TO START COPYING TO + MOV B,D ;AND D POINTS TO THE NEXT FREE BLOCK +MOVNXT: MOV D,C ;GET POINTER TO START OF NEXT FREE BLOCK + ADD SIZE(D),C ;MAKE C POINT TO THE USED BLOCK AFTER IT + MOV (D),D ;AND UPDATE D TO POINT TO NEXT FREE BLOCK ON LIST + BNE COLAPS ;THERE IS ANOTHER BLOCK, DONT WORRY ABOUT TOP OF ARRAY SPACE + CMP C,ARTOP ;IS THIS FREE BLOCK THE LAST BLOCK IN ARRAY SPACE? + BEQ PSDONE ;YES, WE ARE DONE + MOV ARTOP,D ;PRETEND THAT THE END OF THE USED BLOCK IS THE END OF + ;ARRAY SPACE +COLAPS: MOV SIZE(C),A ;GET THE LENGTH OF THE USED ARRAY + ASR A ;TURN INTO NUMBER OF WORDS + MOV B,@(C) ;UPDATE THE BINDING POINTER TO POINT TO THE NEW LOCATION +1$: MOV (C)+,(B)+ ;COPY THE ARRAY + SOB A,1$ + CMP C,D ;HAVE WE COPIED THESE CONTIGUOUS USED ARRAYS + BNE COLAPS ;NO, COPY THE NEXT USED ARRAY + CMP D,ARTOP ;HAVE WE COPIED UP TO THE TOP OF ARRAY SPACE + BNE MOVNXT ;NO, THEREFORE DO THE NEXT USED BLOCK +PSDONE: +.IFNZ LSI + MOV B,ARTOP ;FIRST FREE SPACE IS NOW TOP + CLR ASPACE ;GIVING UP ALL FREE SPACE + CLR B ;NO FREE POINTER +.ENDC + MOV B,AROVER ;FROM NOW ON, ALLOCATE FROM HERE + MOV B,AFREE ;B NOW POINTS TO THE FIRST AND ONLY FREE BLOCK +.IFZ LSI + BEQ 2$ ;NO FREE BLOCKS + MOV ASPACE,SIZE(B) ;ITS SIZE IS THE AMOUNT OF FREE STORAGE LEFT + CLR (B) ;NO MORE BLOCKS OF FREE STORAGE + CLR BKPTR(B) ;AND NO PREVIOUS ONE +2$: +.ENDC + SPOP D + SPOP C + SPOP B + SPOP A + RTS PC + + +.GLOBL GETAML +;PUT INTO A THE CONTENTS OF THE MEMORY LOCATION POINTED TO BY A +GETAML: +.IFNZ TS ;THIS IS NECCESSARY BECAUSE MFPI DOESN'T WORK IN USER MODE + SAVE A + $MFPI + REST A +.IFF + MOV (A),A ;NOW WASN'T THAT MUCH SIMPLER? +.ENDC + RTS PC + +.IFNZ TS +HALCRO: JSR PC,G1NARG + MOV B,A + MOV HALLLM,C ;LAST LIMIT + SUB HALLIM,C ;AMMOUNT ALREADY ALLOCATED + SUB C,B ;ADDITIONAL AMOUNT TO BE ALLOWED + BGE 1$ + ERROR+WTA +1$: MOV B,HALLIM + MOV A,HALLLM + SEZ + RTS PC +.ENDC + .SBTTL P AND S PDL SWAP OUTERS + +;** NOTE: ALTHO PDL EMERGENCIES WITH DISK CAN ONLY OCCUR WHEN TIMESHARING, +;** WITHOUT THE DISK PDL EMERGENCIES CAN *ALWAYS* OCCUR (DUE TO NODE/ARRAY SPACE +;** HAVING SNUCK UP ON THE PDL BUFFERS) AND THUS MUST BE ACCOUNTED FOR REGARDLESS +;** OF TS. + +.IFNZ DSK + +PPSWPO: JSR F,ACSAV ;TIME TO WORK! +.IFNZ TS + TST PPEMR ;HAS A P PDL EMERGENCY ALREADY OCCURED? + BEQ 1$ ;NOPE + ERROR+FBUG ;SYSTEM BUG!! +1$: JSR F,SETUPP + .BLKO + BEQ PPEMRP ;GO DO AN EMERGENCY PUSH OF THE STACK + DEC HALLIM + BLE 2$ + CMP PPLIMT,PRBAO ;ARE WE BEYOND THE LIMIT ON P YET? + BHI PPSWP1 +2$: BIS #DSAMFL,FLAGS2 ;YES, SET DISK ALMOST FULL +.ENDC +PPSWP1: MOV POPLM,PPOPL ;NONE OUT BEFORE, CHANGE LIMIT + BIS #PPNAIF,FLAGS2 ;CERTAINLY NOT ALL IN NOW + MOV IP,A + MOV #PSWPAD,B ;ADDRESS PDL SWAPED FROM + MOV -(B),-(A) + CMP B,P + BHIS .-4 + ADD #PPDLL,P ;PDL HAS MOVED! + ADD #PPDLL,PRBAO + JSR F,ACRES + RTS PC + +.IFNZ TS +PPEMRP: MOV PC,PDLEMR ;FLAG THAT A PDL EMERGENCY OCCURED + MOV PC,PPEMR ;FLAG A P PDL EMERGENCY + CLR -(P) + CLR -(P) + SAVE PPDLCP + BIS #.FASP,(P) + $INVOK ;SET POINTER TO BEG OF FILE + $BLKO ;OUTPUT THIS PDL BLOCK (CAN'T FAIL!!) + DEC HALLIM + BIS #DSAMFL,FLAGS2 ;WARN THE REST OF THE SYSTEM WE ARE IN TROUBLE + BR PPSWP1 +.ENDC +.ENDC +.IFZ DSK + +;ROUTINE TO EXTEND P-PDL SPACE (IN LIEU OF SWAPPING OUT) +PPSWPO: JSR F,ACSAV + TST PPEMR ;PENDING EMERGENCY? + BEQ 1$ + ERROR+FBUG +1$: BIS #PPNAIF,FLAGS2 ;NOT ALL "SWAPPED IN" (IE, >1 PDL BLOCK EXISTS) + MOV PPDTOP,A ;A_TOP OF STACK SPACE + SUB #PPDLL,A ;EXTEND IT + CMP A,ARTOP ;BUMP INTO ARRAY SPACE? + BLO PPEMRP ;NO, EMERGENCY PUSH + MOV A,PPDTOP ;ANOTHER BLOCK ALLOCATED + SUB #PPDLL,PPUSHL ;PPUSHL MOVED ACCORDINGLY + ADD #<2*PPDLL>-,A + MOV A,PPOPL ;AS WELL AS PPOPL +PPSWP2: ADD #PPDLL,PRB ;ONE MORE BLOCK "ALREADY OUT" + JSR F,ACRES + RTS PC + +PPEMRP: BIS #DSAMFL,FLAGS2 ;SINGAL "DISK" ALMOST FULL + MOV PC,PPEMR ;FLAG P PDL EMER + SUB #PPDLL-PDSLOP,PPUSHL ;PPUSHL IS NOW JUST UNDER TOP OF EMER BLK + MOV PPDTOP,PPOPL ;NEW PPOPL + ADD #PPDLL-,PPOPL + BR PPSWP2 +.ENDC + .IFNZ DSK + +SPSWPO: JSR F,ACSAV ;TIME TO WORK! +.IFNZ TS + TST SPEMR ;HAS A P PDL EMERGENCY ALREADY OCCURED? + BEQ 1$ ;NOPE + ERROR+FBUG ;SYSTEM BUG!! +1$: JSR F,SETUPS + .BLKO + BEQ SPEMRP ;GO DO AN EMERGENCY PUSH OF THE STACK + DEC HALLIM + BLE 2$ + CMP SPLIMT,SPRBAO ;ARE WE BEYOND THE LIMIT ON P YET? + BHI SPSWP1 +2$: BIS #DSAMFL,FLAGS2 ;YES, SET DISK ALMOST FULL +.ENDC +SPSWP1: MOV SPOPLM,SPOPL + BIS #SPNAIF,FLAGS2 ;CERTAINLY NOT ALL IN NOW + MOV IS,A + MOV #SSWPAD,B ;ADDRESS PDL SWAPED FROM + MOV -(B),-(A) + CMP B,S + BHIS .-6 + ADD #SPDLL,S ;PDL HAS MOVED! + ADD #SPDLL,SPRBAO + JSR F,ACRES ;ALL DONE! + RTS PC + +.IFNZ TS +SPEMRP: MOV PC,PDLEMR ;FLAG THAT A PDL EMERGENCY OCCURED + MOV PC,SPEMR ;FLAG A P PDL EMERGENCY + CLR -(P) + CLR -(P) + SAVE SPDLCP + BIS #.FASP,(P) + $INVOK ;SET POINTER TO BEG OF FILE + $BLKO ;OUTPUT THIS PDL BLOCK (CAN'T FAIL!!) + DEC HALLIM + BIS #DSAMFL,FLAGS2 ;WARN THE REST OF THE SYSTEM WE ARE IN TROUBLE + BR SPSWP1 +.ENDC +.ENDC + +.IFZ DSK + +;ROUTINE TO EXTEND S-PDL SPACE (IN LIEU OF SWAPPING OUT) +;THIS REQUIRES MOVING THE P-PDL +SPSWPO: JSR F,ACSAV + TST SPEMR ;EMERGENCY IN PROGRESS? + BEQ 1$ + ERROR+FBUG +1$: BIS #SPNAIF,FLAGS2 ;NOT ALL "SWAPPED IN" + MOV PPDTOP,A ;A_TOP OF *P*PDL SPACE + SUB #SPDLL,A ;MOVE IT + CMP A,ARTOP ;BUMP INTO ARRAY SPACE? + BLO SPEMRP ;IF SO, EMERGENCY PUSH + MOV A,PPDTOP ;NEW PDL TOP + MOV P,A ;SAVE P-PDL PTR +SPSWPL: MOV (P)+,-(P) ;SLIDE P-PDL UP (DOWN) ONE BLOCK + CMP P,IP ;REACHED THE BOTTOM YET? + BLO SPSWPL ;IF NOT, CONTINUE + + SUB #SPDLL,A ;UPDATE P + MOV A,P + SUB #SPDLL,IP ;ADJUST REMAINING PARAMETERS + SUB #SPDLL,PPUSHL + SUB #SPDLL,PPOPL + SUB #SPDLL,SPUSHL + MOV IP,SPOPL + ADD #<2*SPDLL>-,SPOPL +SPSWP2: ADD #SPDLL,SPRB ;ONE MORE BLOCK "ALREADY OUT" + JSR F,ACRES + RTS PC + +SPEMRP: BIS #DSAMFL,FLAGS2 ;SIGNAL "DISK" ALMOST FULL + MOV PC,SPEMR ;FLAG S-PDL EMERGENCY + SUB #SPDLL-PDSLOP,SPUSHL ;SPUSHL NOW JUST UNDER TOP OF EMER BLOCK + MOV IP,SPOPL + ADD #SPDLL-,SPOPL ;NEW SPOPL + BR SPSWP2 +.ENDC + .SBTTL P AND S PDL SWAPER INERS + +.IFNZ DSK + +PPSWPI: BIT #PPNAIF,FLAGS2 ;IS THE PDL ALL THE WAY IN? + BNE 1$ ;NO (PRAISE THE LORD!) + ERROR+FBUG +1$: JSR F,ACSAV + MOV #PSWPAD,A + MOV A,B + ADD #PPDLL,A + MOV -(A),-(B) + CMP A,P + BHI .-4 + SUB #PPDLL,P + SUB #PPDLL,PRBAO + BNE PSWPI3 + BIC #PPNAIF,FLAGS2 + MOV IP,PPOPL +PSWPI3: +.IFNZ TS + JSR F,SETUPP + $BLKI + INC HALLIM ;GIVE BACK A BLOCK +.ENDC + JSR F,ACRES + RTS PC +.IFNZ TS +SETUPP: TST (P)+ + TST SPEMR ;IS THERE A S PDL EMRG? + BNE 1$ ;YES + BIC #DSAMFL,FLAGS2 ;NO, DISK IS NOW NOT ALMOST FULL +1$: TST PPEMR ;HAS A P PDL EMERGENCY OCCURED? + BEQ SETUP1 ;NO, DO NORMAL THING + CLR -(P) ;GO TO START OF FILE FOR EMERGENCY BLOCK + CLR PPEMR ;NO MORE EMERGENCY! + BR SETUP2 +SETUP1: SPUSH PRBAO + ADD #PPDLL,(P) ;SKIP THE EMERGENCY BLOCK +SETUP2: CLR -(P) + SPUSH PPDLCP + BIS #.FASP,(P) + $INVOK + SPUSH #PSWPAD + SPUSH #-PPDLL + SPUSH PPDLCP + JMP (F) +.ENDC +.ENDC + +.IFZ DSK + +;ROUTINE TO CONTRACT P-PDL SPACE (IN LIEU OF SWAPPING IN) + +PPSWPI: BIT #PPNAIF,FLAGS2 ;ANYTHING TO POP? + BNE 1$ ;YES (THANK TOASTER!) + ERROR+FBUG +1$: JSR F,ACSAV + SUB #PPDLL,PRB ;ONE LESS BLOCK + BNE PSWPI3 ;IF THAT LEAVES NO EXTRAS, + BIC #PPNAIF,FLAGS2 ; SO FLAG + MOV IP,PPOPL ;NEW PPOPL FOR BLOCK 0 + BR PSWPI4 +PSWPI3: ADD #PPDLL,PPOPL ;NEW PPOPL FOR BLOCK > 0 +PSWPI4: TST SPEMR ;SPDL EMERGENCY? + BNE 1$ + BIC #DSAMFL,FLAGS2 ;NO, SO "DISK" NO LONGER FULL +1$: TST PPEMR ;PPDL EMERGENCY? + BEQ SETUP1 + CLR PPEMR ;NO MORE + ADD #PPDLL-PDSLOP,PPUSHL ;YES, NEW PPUSHL + BR SETUP2 ;NO BLOCK POPPED HERE +SETUP1: ADD #PPDLL,PPUSHL ;NEW PPUSHL + ADD #PPDLL,PPDTOP ;POP TO NEW PPDTOP +SETUP2: JSR F,ACRES + RTS PC +.ENDC + + +.IFNZ DSK + +SPSWPI: BIT #SPNAIF,FLAGS2 ;IS THE PDL ALL THE WAY IN? + BNE 1$ ;NO (PRAISE THE LORD!) + ERROR+FBUG +1$: JSR F,ACSAV + MOV #SSWPAD,A + MOV A,B + ADD #SPDLL,A + MOV -(A),-(B) + CMP A,S + BHI .-6 + SUB #SPDLL,S + SUB #SPDLL,SPRBAO + BNE SPSWI3 + MOV IS,SPOPL + BIC #SPNAIF,FLAGS2 +SPSWI3: +.IFNZ TS + JSR F,SETUPS + $BLKI + INC HALLIM +.ENDC + JSR F,ACRES + RTS PC +.IFNZ TS +SETUPS: TST (P)+ + TST PPEMR ;IS THERE A P PDL EMRG? + BNE 1$ ;YES + BIC #DSAMFL,FLAGS2 ;NO, DISK IS NOW NOT ALMOST FULL +1$: TST SPEMR ;HAS EMERGENCY OCCURED? + BEQ SETUS1 ;NOPE + CLR -(P) ;GET EMERGENCY BLOCK THEN + CLR SPEMR ;NO MORE EMERGENCY + BR SETUS2 +SETUS1: SPUSH SPRBAO + ADD #SPDLL,(P) ;PASS BY EMRG BLOCK +SETUS2: CLR -(P) + SPUSH SPDLCP + BIS #.FASP,(P) + $INVOK + SPUSH #SSWPAD + SPUSH #-SPDLL + SPUSH SPDLCP + JMP (F) +.ENDC +.ENDC + + .IFZ DSK + +;ROUTINE TO CONTRACT S-PDL SPACE (IN LIEU OF SWAPPING IN) +;THIS REQUIRES SLIDING THE P-PDL UP + +SPSWPI: BIT #SPNAIF,FLAGS2 ;ANYTHING TO POP? + BNE 1$ + ERROR+FBUG +1$: JSR F,ACSAV + SUB #SPDLL,SPRB ;ONE LESS BLOCK + BNE SPSWI3 ;IF THAT LEAVES NO EXTRAS, + BIC #SPNAIF,FLAGS2 ; SO FLAG + MOV IS,SPOPL ;NEW SPOPL FOR BLOCK 0 + BR SPSWI4 +SPSWI3: ADD #SPDLL,SPOPL ;NEW SPOPL FOR BLOCK > 0 +SPSWI4: TST PPEMR ;PPDL EMERGENCY? + BEQ 1$ + BIC #DSAMFL,FLAGS2 ;NO, SO "DISK" NO LONGER FULL +1$: TST SPEMR ;SPDL EMERGENCY? + BEQ SETUS1 + CLR SPEMR ;NO MORE + ADD #SPDLL-PDSLOP,SPUSHL ;YES, NEW SPUSHL + BR SETUS2 ;NO PPDL SLIDE NEEDED +SETUS1: ADD #SPDLL,SPUSHL ;YES, NEW SPUSHL + MOV IP,A + ADD #SPDLL,IP ;POP TO NEW SPDL TOP +SETUSL: MOV -(A),SPDLL(A) + CMP A,P + BHI SETUSL + ADD #SPDLL,P ;ADJUST PPDL PARAMETERS + ADD #SPDLL,PPDTOP + ADD #SPDLL,PPUSHL + ADD #SPDLL,PPOPL +SETUS2: JSR F,ACRES + RTS PC +.ENDC + .GLOBL MKSSP +.IFNZ DSK +MKSSP: TST SPRBAO + BEQ MKSP4 + CLR -(P) + CLR -(P) + SAVE SPDLCP + BIS #.FASP,(P) + $INVOK ;GO TO BEG OF FILE + SAVE <#SSWPAD,#-SPDLL,SPDLCP> + $BLKO + CLR SPMSWP +MKSP8: ADD #2000,SPMSWP + CMP SPMSWP,SPRBAO + BHI MKSP6 ;NO +MKSP5: SAVE <#SSWPAD,#-SPDLL,SPDLCP> + $BLKI + MOV #SSWPAD,E + MOV #SPDLL/2,F +MKSP7: MOV (E)+,B ;MARK THIS PIECE OF S PDL + JSR PC,MARKV + SOB F,MKSP7 + BR MKSP8 + +MKSP6: CLR -(P) + CLR -(P) + SAVE SPDLCP + BIS #.FASP,(P) + $INVOK + SAVE <#SSWPAD,#-SPDLL,SPDLCP> + $BLKI + CLR SPMSWP +MKSP4: RTS PC +.IFF +MKSPSW: +MKSSP: RTS PC +.ENDC +.IFNZ DSK +MKSPSW: TST SPMSWP ;TOP OF PDL SWAPED OUT FOR MARKING? + BEQ 1$ ;NO, JUST ERROR OUT + CLR -(P) + CLR -(P) + SAVE SPDLCP + BIS #.FASP,(P) + $INVOK ;ACCESS BEG OF FILE + SAVE <#SSWPAD,#-SPDLL,SPDLCP> ;INPUT THE BLOCK IT WAS SAVES ON + $BLKI +1$: RTS PC +.ENDC + +.IFNZ LSI +.IF Z LSMAP +LSGDBA: MOV LSDBAD,B + RTS PC + +LSBITM: MOV GCBITA,GCBITS + RTS PC +.IFF +.IF NZ RKDSK +LSGDBA: MOV LSDBAD,B + RTS PC +.IFF +LSGDBA: MOV LSDBAD,B +.ENDC +LSBMAP: TST GOTMAP + BEQ 1$ + MOV #MAPON!MAPHCK,MAPCSR + MOV B,MAPADR + MOV #MAPHCA,B +1$: RTS PC + +LSBITM: SAVE B + MOV GCBITA,B + JSR PC,LSBMAP + MOV B,GCBITS + REST B + RTS PC +.ENDC + + + + +.IFF +LSBITM: RTS PC +.ENDC + +.IF Z LSI +GETERW: MOV (B),B + RTS PC + +GETERB: MOVB @ERRPT,D + RTS PC + +.IFF + +.IF Z LSMAP +GETERW: ADD RERTXT,B + MOV (B),B + RTS PC + +GETERB: MOV RERTXT,D + ADD ERRPT,D + MOVB (D),D + RTS PC + +.IFF +GETERW: TST GOTMAP + BEQ 1$ + JSR PC,MAPEB +1$: ADD RERTXT,B + MOV (B),B + RTS PC + +GETERB: TST GOTMAP + BNE 1$ + MOV RERTXT,D + ADD ERRPT,D + MOVB (D),D + RTS PC + +1$: SAVE B + MOV ERRPT,B + JSR PC,MAPEB + MOVB (B),D + REST B + TST D + RTS PC + +MAPEB: SAVE A + MOV B,A + BIC #176000,B + ADD #MAPHCA,B + BIC #1777,A + ASH #-10.,A + ADD RERTXT,A + MOV #MAPON!MAPHCK,MAPCSR + MOV A,MAPADR + REST A + RTS PC +.ENDC +.ENDC + + +;WHAT A RANDOM PLACE TO PUT THE METER STUFF. I BET I'LL NEVER FIND IT AGAIN. +.IF NZ METERS + +METER: JSR PC,G1NARG + ASL B + ASL B + ADD #MTZER,B ;GET TO METER ZERO + MOV 2(B),A + MOV (B),B + JSR PC,GRBAD ;MAKE NODE UP WITHT THE NUMBER IN IT + BIS #INUM,C ;POINT TOT HE NUMBER + JMP ORTC ;RETURN IT + +METERG: JSR PC,G1NARG + MOV B,MTFLAG ;ZERO=> ON, NON-ZERO => OFF + BGE 1$ ;NEGATIVE WILL ZERO METERS AND START THEM + MOV #MTZER,A +2$: CLR (A)+ + CMP #MTZERE,A + BNE 2$ +1$: SEZ + RTS PC + +.ENDC