'This file is an annotated version of sysdefs.
Comments (by Dan Ingalls and Diana Merry) are in string-quotes like this.
The code portion of this file is copyright Xerox Corp. 1974'
'Phase I.
The bootstrap process sets up a global dictionary. It then reads input lines, looking specifically for the defining word, to, and calling its code directly.'
to to x (CODE 19)
'Now definitions can be made by evaluating to in ST code'
to read (CODE 2)
'Read input into a vector. The bootstrap reader is almost identical in function to the SMALLTALK read routine, except that DOIT is signalled by <CR> at zero-th parenthesis level, and single-quote strings are ignored.'
to vector (CODE 3)
'This defines the eval method (and more that will be described later) for code vectors.'
to USER (read eval)
'This is the top-level user program. Its class variables also serve as the global symbol table (also known in the interpreter as TopLev).'
'Phase II.
As soon as USER has been defined (ie from here on), it provides the code to execute in each cycle of Smalltalk execution.'
to isnew (CODE 5)
to falseclass (isnew)
to atom x y (CODE 29)
"false _ falseclass.
to print (%..)
':x.Print its address in octal.
Printing goes to the same place as CODE 20. This is used primarily
for bootstrapping. All system classes will print themselves.'
'MESSAGE HANDLING'
to : (CODE 18)
'to : name
%" ?(:"name nil ?(!name_caller message quotefetch)
(!caller message quotefetch))
Fetch the next thing in the message stream unevaluated
and bind it to the name if one is there.
%# ?(:"name nil ?(!name_caller message referencefetch)
(!caller message referencefetch))
Fetch the reference to next thing in the message stream
and bind it to the name if one is there.
(:"name nil ?(!name_ caller message evalfetch)
!caller message evalfetch)
Fetch the next thing in the message stream evaluated
and bind it to the name if one is there.'
to % (CODE 17)
':"token. token=caller.message.code[caller.message.pc]?
(caller.message.pc_caller.message.pc+1. !true) !false.
That is, if a match for the token is found in the message, then
gobble it up and return true, else return false.'
to (CODE 36)
'Fetch the next token quoted -- equivalent to (:").'
to ! (CODE 13)
':x. then do a return, and apply x to any further message. Note
that in (... !x+3. "y_y-2), the assignment to y will never
happen, since ! causes a return.'
to " (CODE 9)
'!:". That is, get the next thing in the message stream unevalled
and active return it (which causes it to be applied to the message).'
to # (:# )
'Returns a REFERENCE to its arguments binding.'
'CONTROL CLASSES'
to repeat token (:#token. CODE 1)
'repeat (token eval) Not a true apply to eval, and therefore token
MUST be a vector.'
to done x (%with?(:x. CODE 25) CODE 25)
'done causes a pop out of the nearest enclosing repeat, for, or do.
done with val will cause the repeat to have value val'
to again (CODE 6)
'repeat ("active_active caller. eq active. class #repeat?(done)).
That is, redo the most recent repeat, for, or do loop.'
to if exp (:exp?(%then?(:exp. %else?(:". exp)exp)error "(no then))
%then?(:". %else?(:exp) false)error "(no then))
'The ALGOL if ... then ... else ...'
to for token step stop var start exp (
:"var. (%_?(:start.)"start_1).
(%to?(:stop.)"stop_start.)
(%by?(:step.)"step_1.)
%do. :#exp. CODE 24)
'An Algol-like for.
Note the default values if _,to,by,etc., are omitted.
CODE 24 means --repeat(exp eval). This implies done and again
will work, which is correct.'
to do token step stop var start exp (
"step_"start_1. :stop. :#exp. CODE 24)
'INITIALIZING SYSTEM CLASSES
Here are the main kludges which remain from the time when we
really didn|t understand classes very well, but wanted a working
SMALLTALK. PUT and GET are two of the principle actions of class
class. The new verson of SMALLTALK will have class as a class
with these actions intensional.'
to PUT x y z (:#x. :y. :z. CODE 12)
'The first argument MUST be an atom which is bound to a class
table. The third argument is installed in the value side of that table
corresponding to the name (atom) which was the second argument.'
to GET x y (:#x. :y. CODE 28)
'If x is a class table then the binding of the atom in y will be
fetched.'
to leech field bits : ptr (
isnew?(:ptr)
CODE 27)
'Lets you subscript any instance
a[0] gives you the class, a[1] gives the first field, etc.
a[2] gives you the pointer; a[2]& returns the BITS in an integer
a[2]_foo will dereference count previous contents, but a[2]&_ foo
will not.'
to atom x y (CODE 29
'%_?(:x. !x -- Lookup SELF and replace its value by x.)
%eval?(! -- Lookup the binding of SELF)
%=?(!SELF=:)
%chars?(! -- printname of SELF (a string))'
%is?(ISIT eval)
%print?(disp_SELF chars) )
'Done this way (PUT used rather than using to) because we
wanted to know where the system classes are. Hence the initial
to atom x y () , for example, in Bootstrapping Magic followed
by the behavior here.'
to falseclass (CODE 11
'%?? (:".)
%or? (!:)
%and? (:.)
%<? (:.)
%=? (:.)
%>? (:.)'
isnew.
%is?(%false?(!true) %~? (!"false) :".)
%print?("false print) )
to vector x y : : substr (CODE 3 ?(!substr SELF x GLOB MESS)
'isnew?(Allocate vector of length :.
Fill vector with nils.)
%[?(:x. %].
(%_?(:y. !y -- store y into xth element. )
! xth element) )
%length?(! length of string or vector)
%eval?("pc_0. repeat
(null SELF["pc_pc+1]?(done)
"val_SELF[pc] eval)
!val) sort of...'
%is?(ISIT eval)
%print?(disp_40. for x to SELF length
(disp_32. SELF[x] print). disp_41)
%map?(:y. for x to SELF length
(evapply SELF[x] to y)) )
to string x y : : substr (CODE 3 ?(!substr SELF x GLOB MESS)
'isnew?(Allocate string of length :.
Fill string with 255s.)
%[?(:x. %].
(%_?(:y. !y -- store y into xth element. )
! xth element) )
%length?(! length of string or vector)'
%is?(ISIT eval)
%print?(0 = "x _ SELF[1 to 9999] find first 39?
(disp _ 39. disp _ SELF. disp _ 39)
SELF[1 to x - 1] print. SELF[x+1 to SELF length] print)
%=?(:y is string?(SELF length=y length?(
for x to SELF length (SELF[x]=y[x]?() !false)) !false)
!false)
%+?(:y is string?("x_SELF[1 to SELF length+y length].
!x[SELF length+1 to x length]_y[1 to y length])
error "(string not found)) )
to number x y : : nprint (CODE 4
'%+?(!val+:)
%-?(!val-:)
%*?(!val*:)
%/?(!val/:)
%<?(!val<:)
%=?(!val=:
%>?(!val>:)
%& ?(%+?(!val OR :)
%-?(!val XOR :)
%*?(!val AND :)
%/?(!val LSHIFT :)))'
%is?(ISIT eval)
%print?(SELF>0?(nprint SELF)
SELF=0?(disp_48)
disp_21. nprint 0-SELF) )
'For floating point stuff see FLOAT'
to disp x i (
%_?(:x is string?(for i to x length (disp_x[i])) CODE 23)
%clear?() %sub?(:x eval))
'Writes a character or string to the bootstrap printer.
Later it will redefined as a display frame.'
to cr (disp_13)
to sp (disp_32)
to ev (repeat (cr read eval print))
to USER (ev)
'The top-level user process is now defined.
The bootstrap reader stops here, and USER starts to run.'
to - x (:x*-1)
'An often used abbreviation, has to work for float as well.'
to base8 i x s (:x. "s_string 7. for i to 7
(s[8-i] _ 48 + x &* 7. "x _ x &/ -3). !s)
'Returns a string containing the octal representation (unsigned) of its
integer argument.'
"ISIT _ "(%~?(!TITLE) !TITLE=:").
to nil x (#x)
'nil is an unbound pointer, which is used to fill vectors and
tables.'
to eq (CODE 15)
'(! : is-identical-to :) - compare 2 SMALLTALK pointers.'
to null x y (:x. ! eq #x #y)
'Null returns true if its message is nil, otherwise false.'
'UTILITIES'
to mem x y (:x. CODE 26)
'to mem x y (:x. %_?(!core/mem x _:)!core/mem x)
mem loads integers from and stores them into real core.
Tee hee...
mem 280 _ 0 --set alto clock to zero
mem 280 ;read the clock
for i to 16 (mem 280+i _ cursor[i]) --put new bits into cursor
mem 276 _ mem 277 _ 0. --reset mouse x and y to 0.
mem 69 _ 0. --disconnect cursor from mouse
mem 278 _ x. mem 0427 _ y. --move the cursor
mem 71 _ 127. --make DEL the interrupt char (instead of ESC).
mem 272. --get pointer to display control block
mem 65052. --reads the first of 4 keyboard input words
mem 65048. --reads the word with mouse and keyset bits.'
to mouse x (:x. CODE 35)
' x = 0-7 are a map on the mouse buttons. E.g. (4=mouse 4) comes
back true if the top mouse button is depressed, (1=mouse 1) comes
back true if bottom mouse button depressed, (7=mouse 7) comes
back true if all three mouse buttons depressed, etc. Mouse 8
returns the x coordinate of the mouse and mouse 9 returns the y
coordinate.'
to mx (!mouse 8)
to my (!mouse 9)
to core ((mem 63)-mem 62)
'Returns the amount of space left in your Smalltalk.'
to kbd i ("i _ 0. CODE 20)
'Waits until a key is struck. Returns an ascii code when a key is
struck on the keyboard.'
to dsoff (mem 272_0)
'Turns display off by storing 0 in display control block ptr. Speeds
up Alto Smalltalk by factor of 2.'
to dson (mem 272 _ 58)
'Turns display back on by refreshing display control block
pointer.'
to apply x y (:#x. %to?(:y. %in?(:GLOB. CODE 10) CODE 10)
%in?(:GLOB. CODE 10) CODE 10)
to evapply x y (:x. %to?(:y. %in?(:GLOB. CODE 10) CODE 10)
%in?(:GLOB. CODE 10) CODE 10)
'Causes its argument to be applied to the message stream of the
caller, or, in the case of apply foo to <vector>, to that vector.
Note that only the message is changed, and that the caller is not
bypassed in any global symbol lookup unless the in-clause is used to
specify another context.'
"true_"true
"eval_"eval
to is ( %~?(!"untyped):". !false)
'These are used to handle messages to classes which can|t answer
queston invoking is, eval, etc.'
to t nprint substr (ev).
t 'prevent -to- from making these global.'
to nprint digit n (:n=0?()
"digit_n mod 10. nprint n/10. disp_48+digit)
PUT number "nprint #nprint.
'Prints (non-neg) integers in decimal with leading zeroes suppressed'
to substr op byte s lb ub s2 lb2 ub2 (
:#s. :lb. :ub. :MESS. "GLOB_ub. 'tee hee'
:ub. (%]?() error "(missing right bracket))
"byte _ "lb2 _ "ub2 _ 1.
%find? ("op _ (%first?(1) %last?(2) 1)
+ (%non?(2) 0). :byte. CODE 40)
%_? (%all? (:byte. "op_0. CODE 40)
:#s2. "op_5.
%[? (:lb2. %to. :ub2. %]. CODE 40)
"ub2_9999. CODE 40)
"op _ 6. CODE 40).
PUT string "substr #substr.
PUT vector "substr #substr.
done 'end of subevaluation in t'
'substr takes care of copying, moving and searching within strings
and vectors. It first gets its father (string/vector) and the lower
bound, and then proceeds to fetch the rest of the message from
above. Some examples:
"(a b c d e)[2 to 3] -> (b c)
"(a b c d e)[1 to 5] find "c -> 3
"(a b c d e)[1 to 5] find "x -> 0
See vecmod for more examples. String syntax is identical.'
to vecmod new end old posn ndel nins ins ("end_10000.
:old. :posn. :ndel. :ins.
"nins_(ins is vector?(ins length) 1).
"new _ old[1 to old length+nins-ndel].
(ins is vector?(new[posn to end] _ ins[1 to nins]) new[posn]_ins).
new[posn+nins to end] _ old[posn+ndel to end].
!new)
'Vecmod makes a copy of old vector with ndel elements deleted
beginning at posn. If ins is a vector, its elements are inserted at
the same place. It is the heart of edit.'
to addto func v w (:#func. :w. "v_GET func "DO. null v?(error "(no code))
PUT func "DO vecmod v v length 0 w)
'Addto appends code to a class definition.'
to fill t i l str (
"l _ :str length. "i _ 0.
repeat
(i = l?(done)
"t _ kbd. str["i _ i + 1] _ t. disp _ t. t=13?(done)).
!str)
to stream in : i s l(
CODE 22
' CODE 22 is equivalent to...
%_?
(
(i = l?
("s _ s[1 to "l _ 2 * l]))
!s["i _ i + 1] _ :)
%next?
(i = l?(!0)
!s["i _ i + 1])
%contents?
(!s[1 to i])'
%reset?
("i _ 0)
isnew?
("s _
(%of?(:)
string 10).
"i _
(%from?((:)
- 1)
0).
"l _
(%to?(:)
s length))
%is?
(ISIT eval)
%end?
(!i = l)
%print?
(
(i > 0?
(s[1 to i] print)).
disp _ 1.
l < i + 1?()
s[i + 1 to l] print))
to obset i input : vec size end (
%add?((size="end_end+1?("vec_vec[1 to "size_size+10]))
vec[end]_:)
%_?(0=vec[1 to end] find first :input?
(SELF add input))
%delete?(0="i_vec[1 to end] find first :input?(!false)
vec[i to end]_vec[i+1 to end+1]. "end_end - 1)
%unadd?("input_vec[end]. vec[end]_nil.
"end_end - 1. !input)
%vec?(!vec[1 to end])
%map?(:input. for i _ end to 1 by -1 (input eval))
%print?(SELF map "(vec[i] print. sp))
%is?(ISIT eval)
isnew?("end_0. "vec_vector "size_4)
)
to { set ("set_stream of vector 10. repeat(
%}?(!set contents)
set _ :)
)
'PRETTY-PRINT
This prints the code; classprint makes the header.'
to show func t (
:#func. "t_GET func "DO.
null t ? (!"(no code)) pshow t 0.)
to pshow ptr dent i t :: x tabin index (:ptr :dent.
(ptr length>4?(tabin dent)) disp_40.
for i to ptr length
("t _ ptr[i].
t is vector ?(pshow t dent+3.
i=ptr length?()
". = "x_ptr[i+1]?()
x is vector?()
tabin dent)
i=1 ?(t print)
0<"x_index "(. , [ ] ?) t?
(x=1?(t print. i=ptr length?()
ptr[i+1] is vector?() tabin dent)
t print)
0=index "(: " # ! [ % ? & ) ptr[i - 1]?(disp_32. t print)
t print)
disp_41)
to t tabin index (ev)
t
to tabin n :: x (:n. disp_13. repeat
(n > 6?
(disp _ x[6].
"n _ n - 6)
done)
disp _ x[n + 1])
(PUT tabin "x {string 0 fill string 1 fill string 2 fill string 3
fill string 4 fill string 5 fill string 6}).
'leave these blanks'
PUT pshow "tabin #tabin.
to index op byte s lb ub s2 lb2 ub2 (
:s. :byte. "op_"lb_"s2_"lb2_"ub2_1. "ub_9999. CODE 40)
'A piece of substr which runs faster.'
PUT pshow "index #index.
done
'FLOATING POINT'
to float x y : : fprint (CODE 42
%ipow?
(:x = 0?(!1.0)
x = 1?()
x > 1?
(1 = x mod 2?
(!SELF *(SELF * SELF)
ipow x / 2)
!(SELF * SELF)
ipow x / 2)
!1.0 / SELF ipow 0-x)
%epart?
(SELF < :x?(!0)
SELF < x * x?(!1)
!
("y _ 2 * SELF epart x * x)
+
(SELF / x ipow y)
epart x)
%is?(ISIT eval)
%print?
(SELF = 0.0?(disp _ 48. disp_46. disp_48)
SELF < 0.0?
(disp _ 21.
fprint - SELF)
fprint SELF)
)
to t fprint (ev)
t
to fprint n i p q s : : fuzz (
'Normalize to [1..10]'
(:n < 1?
("p _ -(10.0 / n)
epart 10.0)
"p _ n epart 10.0)
"n _ fuzz + n / 10.0 ipow p.
'Scientific or decimal'
("q _ p.
"s _ fuzz*2.
p > 6?
("p _ 0)
p < -3?
("p _ 0)
"q _ 0.
p < 0?
(disp _ 48. disp_46.
for i _ p to -2(disp _ 48))
"s _ s * 10.0 ipow p)
'Now print (s suppresses trailing zeros)'
for i to 9
(disp _ 48 + n ipart.
"p _ p - 1.
"n _ 10.0 * n fpart.
p < 0?
(
(p = -1?(disp _ 46))
n < "s _ 10.0 * s?(done)))
(p = -1?(disp _ 48))
q = 0?()
disp_101.
q print)
PUT fprint "fuzz 5.0 * 10.0 ipow -9.
PUT float "fprint #fprint.
done
'TEXT DISPLAY ROUTINES
Display frames are declared with five parameters. They are a left x, a width, a top y, a height, and a string. Hence --
"yourframe_dispframe 16 256 16 256 string 400.
-- gets you an area on the upper left portion of the display that starts at x,y 16,16 and is 256 bits(raster units) wide and 256 bits high. The string (buf) serves as the text buffer, and is altered by _ and scrolling.
There are actually two entities associated with display frames--frames and windows. Currently both are given the same dimensions upon declaration (see isnew).
The four instance variables defining the window are winx, winwd, winy, and winht. The boundaries of this rectangle are intersected with the physical display. The window actually used by the machine language will reduce the size of the window, if necessary, to be confined by the physical display. Clipping and scrolling are done on the basis of window boundaries. If a character is in the window it will be displayed. If a string or character cause overflow of the bottom of the window, scrolling will occur.
The four instance variables defining the frame are frmx, frmwd, frmy, and frmht. This rectangle may be smaller or larger than its associated window as well as the physical display. Frame boundaries are the basis for word-wraparound. (Presently, if frmy+ frmht will cause overflow of the window bottom[winx+winht], frmht will get changed to a height consonant with the bottom of the window. This has been done to manage scrolling, but may get changed as we get a better handle on the meaning of frames and windows.).
Buf is the string buffer associated with any given instance of dispframe. This is the string that is picked on the way to microcode scan conversion. When scrolling occurs, the first line of characters, according to frame boundaries, is stripped out and the remainder of the buffer mapped back into itself. If a _ message would overflow this buffer, then scrolling will occur until the input fits.
Last is a buf subscript, pointing to the current last character in the buffer. That is, the last character resulting from a _.
Lstln also points into the buffer at the character that begins the last line of text in the frame. It is a starting point for scan conversion in the _ call.
Mark is set by dread (see below) and points to the character in the buffer which represents the last prompt output by SMALLTALK; reading begins there. Mark is updated by scrolling, so that it tracks the characters. One could detect scrolling by watching mark.
Charx and chary reflect right x and top y of the character pointed to by last.
The reply variable in the instance may be helpful in controlling things. When the reply is 0, it means everything should be OK. That is, there was intersection between the window and display and intersection between the window and the frame. When reply is 1, there was no intersection between the window and the display. A 2 reply means no intersection between window and frame. A 3 reply means window height less than font height -- hence no room for scan conversion of even one line of text. A 4 means that the frame height has been increased in order to accomodate the input. A 5 means the bottom of the window (i.e. window x + window height) has been overflowed --hence that scrolling took place. A 6 means that both 4 and 5 are true.
justify is a toggle for right justifying the contents of a dispframe. The default is 0 and means no justification. Setting it to 1 causes justification on frame boundaries.
The font variable allows for the association of a font other than the default font with the display frame. To get a different font into core say "something _ file <fontfilename> intostring. Then you can say disp ("font_something) or you can declare the font at the same time as the tdispframe is declared as e.g.
"yourframe _ dispframe 3 40 3 40 string 20 font something.'
to dispframe input : winx winwd winy winht frmx frmwd frmy frmht last mark lstln charx chary reply justify buf font editor : sub frame dread reread defont (
% _ ?(0 CODE 51)
':s. s is number ? (append this ascii char)
s is string ?(append string)
error.'
%?(! eval)
'Allows access to instance variables. For example,
yourframe ("winx_32)
will alter the value of window x in the instance of dispframe
called "yourframe".'
%show?(4 CODE 51 3 CODE 51)
%display?(SELF show. frame black)
'Show clears the intersection of window and frame (see fclear,
below) and displays buf from the beginning through last. A handy
way to clean up a cluttered world.'
%hasmouse?(frmx<mx<frmx+frmwd?(!frmy<my<frmy+frmht)!false)
'Tells you if the mouse is within a frame.'
%fclear?(4 CODE 51)
'Fclear clears the intersection of the window and frame. Hence if
the frame is defined as smaller than the window, only the frame
area will be cleared. If the frame is defined as larger than the
window, only the window area will be cleared, since that space
is in fact your window on that frame.'
%put?(:input. %at. "winx_"frmx_:. "winy_"frmy_"chary_:.
"last_0. "lstln_1. SELF_input. !charx-winx)
'For them as would rather do it themselves.'
%wclear?(5 CODE 51)
'Wclear clears the intersection of a window and the physical
display.'
%scroll?(2 CODE 51)
'Scroll removes the top line of text from the frame|s string buffer,
and moves the text up one line.'
%clear?(1 CODE 51)
'Clear does an fclear and sets the last pointer into the string buffer
to 0 and lstln to 1. It has the effect of cleaning out the string
buffer as well as clearing the frame area.'
%mfindc ?(7 CODE 51)
' Find character.
Takes two arguments -- x and y (typically msex and msey).
Returns vector:
vec[1] = subscript of char in string
vec[2] = left x of char
vec[3] = width of char
vec[4] = topy of char
If vec[1] is -1 x,y is after the end of the string.
If vec[2] is -2 x,y is not in the window.
Sample call:
"myvec_yourframe mfindc mx my.'
%mfindw ?(8 CODE 51)
' Find word.
Takes two arguments -- x and y (typically msex and msey).
Returns vector:
vec[1] = subscript of first char in word
vec[2] = left x of word
vec[3] = width of word
vec[4] = topy of word
If vec[1] is -1 x,y is after the end of the string.
If vec[2] is -2 x,y is not in the window.
Sample call:
"myvec_yourframe mfindw mx my.'
%mfindt ?(6 CODE 51)
' Find token.
Takes two arguments -- x and y (typically msex and msey).
Returns vector:
vec[1] = token count, ala Smalltalk token Spaces and
carriage returns are considered as delimiters,but
multiple delimiters do not bump the count. Text
delimited by single quotes is counted as one
token, and embedded text (i.e. more than one
quote in sequence) will not cause the token count
to be bumped (allows for embedding strings
within strings).
vec[2] = left x of word
vec[3] = width of word
vec[4] = topy of word
If vec[1] is -1 x,y is after the end of the string or not in frame.
If vec[2] is -2 x,y is not in the window.
A sample call--
"variable_yourframe mfindt mx my.'
%read?(!dread)
'Makes a code vector out of keyboard input. See dread below.'
%reread?(!reread :)
'Used by redo and fix. Goes back n(its argument), prompts and does
a read from there. See reread below.'
%sub?("input _ sub :. SELF show. !input)
'Evals its argument in a sub-window. Used by fix and shift-esc.
See sub below.'
%knows?(ev)
'Whilst at the KEYBOARD, one can say
yourframe knows(DOIT)
and get a copy of the evaluator in the context of that instance of
dispframe. Allows access to instance variables without going through
the path.'
%frame ? (apply frame)
'Draws a border of the given color around the frame. E.g.,
yourframe frame - 1.'
%is ?(ISIT eval)
isnew ? ("winx_:frmx. "winwd_:frmwd. "chary_"winy_:frmy.
"winht_:frmht. :buf. "lstln_1.
"mark_"last_"charx_"reply_"justify_0.
"font _ (%font?(:input is string?(input) defont)defont)
%noframe?() frame black) )
dispframe knows
to dread t instr prev (
disp_20. "instr_false. "mark_last.
(null #DRIBBLE?() DRIBBLE flush)
repeat ("prev _ buf[last].
40>disp_"t_kbd?(
t=8?(last<mark?(disp_20)
' Backspace only up to prompt.'
prev=39?("instr_instr is false))
' Backspace out of string flips instr.'
t=30?(instr?() done)
' DOIT checks if in a string.'
t=39?("instr_instr is false)
' Flag is true if in a string'
t=5?(sub "(ev). "last_last - 1. disp show)
' Shift-Esc make sub-eval.'
t=4?(disp_8. "done print. disp_30. !"(done))
))
disp_13. !read of buf [mark+1 to last - 2])
to sub disp (
"disp_dispframe winx+48 winwd - 64 winy+14 winht - 28
string 300 font font.
disp clear. (:)eval)
'Opens a sub-frame, and evals its argument in that context.'
to frame a ("a _ turtle at frmx - 1 frmy - 1.
a width 2 . a ink (%white?("white) %black. "black).
do 2 (a turn 90 go frmwd + 2 turn 90 go frmht + 2) )
'Draws a double line around the frame.'
to reread n i p reader ((null :n?("n_1))
repeat (buf[last] = 20?(disp _ 8. done) disp _ 8).
"p _ last.
for i to n
("p_buf[1 to p - 1] find last 20.
p<1?(done))
i<n?(error "(no code))
!read of buf [p+1 to buf[p+1 to last] find 30])
'Counts back n prompts (n is integer arg) and then does a read from
there. Also erases the line just typed.'
"defont _ fill string 6
ST8.AL
done
to read str ((%of?(:str)). CODE 2)
'Adds the ability to read from a supplied string'
to dclear (0 CODE 52)
'This function takes five parameters --
x width y height value, and clears the display rectangle thus
defined to the value given. A 0 value, for example, puts all
zeros into the rectangle.'
to dcomp (1 CODE 52)
'Just like dclear only complement rectangle.'
to dmove (2 CODE 52)
'This function takes six parameters -- source x width source y
height destination x destination y. It takes the source rectangle
(x and width mod 16|d as in dclear) and moves it to the destination
x and y. Clipping will occur on display boundaries. The source will
remain intact unless it overlaps with the destination, in which case
the over- lapping portion of the destination wins.'
to dmovec (3CODE 52)
'Dmovec takes the same parameters as dmove, but in addition clears
the non-intersecting source material. It is the general case of what
happens on the display screen during a scroll, i.e. scrolling could be
accomplished by saying disp (dmovec winx winwd winy+fontheight
winht-fontheight winx winy). A sample call --
dmovec 0 256 0 256 256 256.
This will move whatever is in the upper left hand corner of the
display to x,y 256,256 -- and then erase the source area. '
to redo (!(disp reread :) eval)
'Causes re-evaluation of the input typed n prompts before this.
Setting last_mark-2 makes the redo statement and its prompt
disappear with a disp show.'
to fix vec ("vec_disp reread :.
(disp sub "(veced vec)) eval)
'Like redo, except that the previous input is given to the editor in a
subwindow. When editing is done, the resulting code is evalled
before returning.'
'TURTLES'
to turtle var : pen ink width dir x xf y yf frame : f (
CODE 21 '%go?(draw a line of length :)
%turn?(turn right : (degrees))
%goto?(draw a line to :(x), :(y))'
%pendn?("pen _ 1. !SELF)
%penup?("pen _ 0. !SELF)
%ink?(%_. :ink. !SELF)
%width?(%_. :width. !SELF)
%xor?("xor _ (%off?(0) 1). !SELF)
%is?(ISIT eval)
%home?("x _ frame frmwd/2.
"y _ frame frmht/2.
"xf _ "yf _ 0. "dir_270. !SELF)
%erase?(frame fclear. !SELF)
%up?("dir _ 270. !SELF)
isnew?("ink _ "black. "pen _ "width _ 1. "xor _ 0.
(%frame?("frame _ :) "frame _ f)
%at?(:x. :y. "dir_270)
SELF home)
)
PUT turtle "f dispframe 0 512 0 512 string 1 noframe.
"@ _ turtle.
'THE TRUTH ABOUT FILES
a file is found in a directory (dirinst) by its file name (fname), and has a one page, 512 character string (sadr). rvec is an optional vector of disk addresses used for random page access.
"fi _
<directory> file <string> old -- finds an old file named <string> in <directory> or returns false if does not exist or a disk error occurs.
"fi _
<directory> file <string> new -- creates a new file or returns false if it already exists. if neither old or new is specified, an existing file named <string> will be found or a new file created. if <directory> is not specified, the current default directory is used.
<directory> file <string> delete -- deletes a file from a directory and deallocates its pages. do not delete the system directory (SYSDIR.) or bittable (SYS.STAT.), or any directories you create.
<directory> file <string> rename <string> -- renames file named by first string in <directory> with second string. currently not implemented for directory files.
<directory> file <string> load -- loads a previously saved memory image (Swat format), thereby destroying your current state.
<directory> file <string> save -- saves your Smalltalk memory.
leader and curadr are the alto disk addresses of page 0 and the current page of the file, respectively. bytec is a character index into sadr.
dirty = 1 if any label block integers (nextp thru sn2) have been changed; = -1 if sadr has been changed; = 0 if the current page is clean. the user need not worry about this unless (s)he deals directly with the label or sadr. it might be noted here that multiple instances of the same file do not know of each others activities or sadr|s.
status is normally 0, -1 if end occurred with the last set; a positive number (machine language pointer to offending disk command block (dcb)) signals a disk error.
the next 8 integers are the alto disk label block. nextp and backp are the forward and backward alto address pointers. lnused is currently unused. numch is number of characters on the current page, numch must be 512, except on the last page. pagen is the current page number. page numbers are non-negative integers, and the format demands that the difference in consecutive page numbers is 1. normal file access starts at page 1, although all files possess page 0 (the leader page). version numbers > 1 are not implemented. sn1 and sn2 are the unique 2-word serial number for the file.
the class function ncheck checks that file names contain alphabetic or legal characters or digits, and end with a period.'
(to file : dirinst fname sadr rvec leader curadr bytec dirty status nextp
backp lnused numch pagen version sn1 sn2 : ncheck x (
%_? (17 CODE 50)
' fi_<integer>, <string>, or <file> --
:x is string? (for i to x length (SELF_x[i]))
x is file? (repeat (x end? (done) SELF_x next))
(numch<"bytec_bytec+1?
(SELF set to write (pagen+bytec/512) bytec mod 512))
sadr[bytec]_x &* 255'
%next? ((%word? (%_? (7)
' fi next word_<integer> -- write integer.
possibly increment pointer to word boundary.
(0=bytec &* 1? () "bytec_bytec+1)
SELF _ :x/256. SELF _ x mod 256.'
6)
' fi next word -- read an integer
(0=bytec &* 1? () "bytec_bytec+1)
!(SELF next*256) + SELF next'
%into? (16)
' fi next into <string> -- read a string
for i to :x length(x[i]_SELF next).!x'
25) CODE 50)
' fi next -- read a character
(numch<"bytec_bytec+1?
(SELF set to read (pagen+bytec/512)
bytec mod 512? () !0)) !sadr[bytec]'
%set? (%to. (%end?(13)
' fi set to end -- set file pointer to end of file.
SELF set to read 16383 0'
%write?(5)
' fi set to write <integer> <integer> -- set file
pointer to :spage :schar. if current page is dirty,
or reset, set to end or page change
occurs, flush current page. read pages until
pagen=spage. allocate new pages after end if
necessary (-1 512 is treated as start of next
page, i.e. pagen+1 0). "bytec_schar'
%read. 4) CODE 50)
' same as write except stop at end'
%skipnext? (18 CODE 50)
' fi skipnext <integer> -- set character pointer relative to
current position. (useful for skipping rather than reading,
or for reading and backing up, but end may not work if
bytec points off the current page) "bytec_ bytec + :.'
%end? (10 CODE 50)
' fi end -- return false if end of file has not occurred.
nextp=0? (bytec<numch?(!false))!false'
%? (! :" eval)
%flush? (12 CODE 50)
' fi flush -- dirty=0? () write current page'
%writeseq? (22 CODE 50)
' transfer words from memory to a file
:adr. :count. for i_adr to adr+count - 1
(SELF next word _ mem i)'
%readseq? (21 CODE 50)
' ...from a file to memory...(mem i _ SELF next word)'
%is? (ISIT eval)
%remove? (dirinst forget SELF)
' remove file from filesopen list of directory'
%close? (dirinst bitinst flush.
SELF flush. SELF remove. !"closed)
' fi close or "fi_fi close (if fi is global) -- flush bittable
and current page, remove instance from filesopen list of
directory'
%shorten? (%to. %here? (SELF shorten pagen bytec) 14 CODE 50)
' fi shorten to <integer> <integer> -- shorten a file SELF set
to read :spage :schar. "x_nextp. "nextp_0.
"numch_schar. "dirty_1. deallocate x and successors'
%print? (disp _ fname)
' file prints its name'
%reset? (11 CODE 50)
' fi reset -- reposition to beginning of file
SELF set 1 0'
%intostring?(SELF set to end.
"x _ string bytec + 512 * pagen - 1.
SELF reset. !SELF next into x)
%random? (SELF set to end. "rvec _ vector pagen.
for x to rvec length (SELF set x 0. rvec[x] _ curadr))
' fi random -- initialize a random access vector to be used
in fi set... new pages appended to the file will not be
randomly accessed'
%pages? (20 CODE 50)
' fi pages <integer> ... <integer> -- out of the same great
tradition as mem comes the power to do potentially
catastrophic direct disk i/o (not for the faint-hearted).
:coreaddress. :diskaddress. :diskcommand. :startpage.
:numberofpages. :coreincrement. if -1 = coreaddress,
copy sadr to a buffer before the i/o call. diskaddress
(=-1 yields curadr) and diskcommand are the alto disk
address and command. startpage is relevant if label checking
is performed. numberofpages is the number of disk pages
to process. coreincrement is usually 0 (for writing in same
buffer) or 256 for using consecutive pages of core. use
label block from instance of fi. copy label block from
instance. perform i/o call. copy curadr and label block
into instance. if -1=coreaddress copy buffer to "sadr".'
isnew? ("fname_ncheck :. fname is false?
(error "(bad file name) !nil)
(null "dirinst _ #curdir?
("dirinst _ directory defdir. dirinst open)).
' set directory instance for file. if curdir is nil
because file was not called from the context of a
directory instance, use the default directory'
%exists? (24 CODE 50. !fname)
' return false if file name does not occur in the
directory'
%delete? (15 CODE 50. !"deleted)
' delete a file (see intro)'
"sadr _ (%using? (:) string 512).
' set up file string buffer'
%rename? ("x _ ncheck :. x is false?
(error "(bad new name)!nil)
file x exists? (error "(name already in use))
2 CODE 50. "fname _ x. 23 CODE 50.
SELF set 0 12. SELF _ fname length.
SELF _ fname. SELF flush. !fname)
' check that the new name is not already in use.
lookup the original file and change its name in its
directory, and in its leader page'
%load? (2 CODE 50. 8 CODE 50)
' lookup an old file and load (overlay) a Swat
memory image; return via save.'
(%old? (2)
sadr[13] _ fname length.
sadr[14 to 13 + fname length] _ fname.
%new? (dirinst filinst is file? (3) 19)
1) CODE 50.
' find an old file or add a new entry (with its
name as a BCPL string in its leader page. special
handling for new directories). machine code may
return false'
%save? (SELF set to write 256 0. SELF reset.
dirinst close. 9 CODE 50)
' allocate a file, close the directory (other files
e.g. DRIBBLE, and directories should be already
closed), and write out the memory image as a Swat
file. when arriving here from a load, return false;
otherwise return the file instance.'
%intostring?(!SELF intostring)
dirinst remember SELF) ))
' finally, file puts itself into the filesopen list of its
directory'
file (ev)
to ncheck str i x :: legal ("str_:.
(str is string?(str length < 255?() !false) !false)
for i to str length
("x _ str[i].
96 < x < 123 ? ('lowercase')
47 < x < 58 ? ('digit')
0 < legal[1 to 6] find x ? ('legal')
64 < x < 91 ? ('uppercase')
!false)
x=46?(!str) !str+ ".chars)
'check that the file name is a proper length string containing only lower/upper case letters, digits, or legal characters. if name does not end with a period, append one.'
PUT ncheck "legal fill string 6
+-$!?.
done
to error adr ptr arec class :: c shocode find sub (
%knows?(!ev)
:ptr. "arec_leech AREC.
disp sub "((0=adr?(ptr print)
mem 66_0. disp_255 &* mem adr.
for adr_adr+1 to adr+(mem adr)&/ -9 (
"ptr_mem adr.
disp_ptr&/ -8. disp_ptr&* 255))
cr c ev))
error knows
to c class code cpc (
null arec[5]?(.) "arec_leech arec[5]. "class_arec[0].
(GET class "TITLE) print. ": print.
arec[6] is vector?(find arec[1]& arec[6] ? (shocode))
find arec[1]& GET class "DO ? (shocode).
)
to shocode i (
for i_1 to code length
(i<cpc - 5?(disp_46) i>cpc+5?(disp_46)
sp. (i=cpc?(disp_25))
code[i] is vector?("$ print) code[i] print).
)
to find adr vec vadr l (
'a tree search in vec for the address adr'
"adr_:. "l_leech :vec.
vec is vector is false?(!false)
"vadr_(leech l)[1]& +1.
(adr>vadr?(adr<vadr+vec length+1?
("cpc _ adr-vadr. "l_0. "code_vec. !true)))
"l_0. for l to vec length
(vec[l] is vector?(find adr vec[l]?(!true)))
!false)
to sub disp ("disp _ GET USER "disp. (:) eval)
done
to kbck i ("i _ 1. CODE 20)
'Returns true if the keyboard has been hit.'
to button n (!:n=mouse 7)
'Returns true if that pattern is being held down'
'THE SMALLTALK EDITOR ---'
to edit func t (:#func.
"t_GET func "DO.
null t ? (!"(no code))
%title? ((veced classprint func header) eval)
PUT func "DO veced t.
!"edited)
'Edit picks up a code vector, makes sure it is not empty and calls
veced to edit the code body. If you say edit foo title, veced will
edit the header as well, and the changed form will be evalled upon
exit to redefine the function, title and all.
Veced can be used on any vector, and is used by FIX as well as
EDIT. It creates two new windows within the default DISP which
exists when it is called. One is used for a menu of commands,
the other becomes the new default window DISP. The new default
is passed to an intermediary; and the newly edited vector is
returned.'
(to veced back newdisp menu x :: menuwidth menulen menustr
ed edtarget gettwo bugin getvec (
%knows?(ev)
"back_false.
disp fclear.
disp ("menu_dispframe winx+winwd-menuwidth menuwidth
winy (winht>139?(winht) 140) string 70
font font.
menu _ menustr.
"newdisp _ dispframe winx winwd-menuwidth+2
winy winht string buf length
font font noframe)
:x. "x _ indisp newdisp (ed x).
disp show.
!x) )
veced knows
"menuwidth _ 64.
"menustr_string 0.
"menulen _ 10.
do menulen ("x_fill string 9.
"menustr_menustr+x[1 to x[1 to 9]find 13]).
Add
Insert
Replace
Delete
Move
Up
Push
Enter
Leave
Exit
to indisp disp (:disp. ! eval)
'used to make DISP a new local.'
to ed ptr l n nrun command temp i nv n1 fnth hfnth (
"command _ 0.
:ptr.
"fnth _ 18.
"hfnth _ fnth/2.
repeat(
"l_ptr length.
back?(done with ptr)
menu show. disp clear
"nv_0.
for n to l
(ptr[n] is vector?(disp_36. sp
"nv_nv+1. "n1_n)
ptr[n] print. disp_32)
cr cr.
"command _ edcomp bugin menu menulen both.
"(
("ptr_vecmod ptr l+1 0 read)
("ptr_vecmod ptr edcomp edtarget both 0 read)
(gettwo. "ptr_vecmod ptr n nrun read)
(gettwo. "ptr_vecmod ptr n nrun vector 0)
(gettwo. "temp _ ptr[n to n+nrun - 1]
"i_edcomp edtarget both.
"ptr_vecmod ptr n nrun vector 0.
(i>n ? ("i_i-nrun))
"ptr_vecmod ptr i 0 temp)
(getvec?("ptr_vecmod ptr n 1 ptr[n]) again)
(gettwo. "temp_vector 1.
temp[1]_ ptr[n to n+nrun - 1].
"ptr_vecmod ptr n nrun temp)
(getvec?(ptr[n]_ed ptr[n]) again)
(done with ptr)
("back_true. done with ptr)
) [command] eval.
)
)
'The heart of ED is a vector, containing as its elements code
vectors. The giant vector is indexed to get the particular piece of
program, and it is sent the message EVAL. Note that the order of
the segments in ED1 should match the order of the atom names in
MENUVEC.'
to gettwo t1 n2 ("n_edcomp edtarget top.
"n2_edcomp edtarget bot.
"nrun _ 1+n2-n.
nrun<1?("n_n2. "nrun_2-nrun))
to bugin someframe max index(
:someframe.
"max _ 1+:.
repeat (button 0 ? (repeat (
button 7 ?(disp sub "(ev))
button 0 ?()
done)
done)
)
"index_someframe mfindt mx my
0<index[1]< max ?
(!index)
'returns token index, if within range, else'
again
'causes an exit out of this command by restarting ed|s
repeat'
)
to edtarget (! bugin disp l)
to getvec (nv=1?("n_n1. !true)
!ptr["n_edcomp edtarget both] is vector)
to edcomp compvec y hth (:compvec.
"y_compvec[4].
"hth_(%both?(fnth)%top?(hfnth)
%bot?("y_y+hfnth. hfnth))
dcomp compvec[2] compvec[3] y hth
!compvec[1]
)
done
'BOOTSTRAPPING REVISITED'
to classprint fn a b i j k flags clsv clsm arecv arecm instv instm code (
:#fn. "code _ GET fn "DO. null code?("(no code))
"a_leech #fn. "b_vector 1. "b_leech b. "clsm_"arecm_"instm_0.
"k_a[1]& . "clsv_vector k. "arecv_vector k. "instv_vector k.
'Pull symbols out of class table'
for i_4 to 4+2*k by 2
'k is no. dbl entries -1, here'
("k_a[i]& .
k = -1?(again). "flags _ k&/ -14.
' 0=class, 2=arec, 3=inst'
flags=0?(0="(DO TITLE ARSIZE) [1 to 3] find a[i]?
(clsv["clsm_clsm+1] _ a[i]))
b[2]& _ k&*2047. "j_a[i+1]& .
(flags=2?(arecv[j - 6] _ b[2]. arecm<j - 6?("arecm_j - 6))
instv[j+1] _ b[2]. instm<j+1?("instm_j+1))
)
'Now make up input form.'
"a _ vector 6+arecm+instm+clsm.
a[1] _ "to. a[2] _ GET fn "TITLE.
a[3 to "j_2+arecm] _ arecv.
(0<instm+clsm? (a["j_j+1]_":. a[j+1 to "j_j+instm] _ instv.
0<clsm? (a["j_j+1]_":. a[j+1 to "j_j+clsm] _ clsv)))
%header?(a[j+1]_code. !a)
for i to j (a[i] print. disp_32)
showpretty?(pshow code 3) code print)
to nshow showpretty ("showpretty_true. showev :" )
to showev shAtom shVal (:shAtom. cr.
(shAtom is atom?
("shVal _ shAtom eval.
(null GET shVal "DO?
("" print. shAtom print. "_ print.
(shVal is vector? ("" print)
null shVal?("nil print))
shVal print. ". print)
classprint shVal))
shAtom print)
disp_30.)
to filout disp flist i showpretty ("showpretty _ %pretty.
dsoff (:disp is string? ("disp_file disp? () error "(file error)))
(%add?(disp set to end))
(null :flist?(defs map "(showev vec[i]. cr))
(flist is atom? (showev flist. "flist_flist eval))
for i to flist length - 1 (showev flist[i]. cr))
disp shorten to here. disp close. dson.)
'Filout basically does a show in an environment where the display is
replaced by a file. filout pretty <file> or <string = file name> add
<vector> if pretty is used, the text representation is neater but
takes longer to generate. if add is used, function definitions are
appended to the file. if <vector> is not specified, defs is
used.'
to filin fi :: ev (%?(! eval)
dsoff.
(:fi is string?("fi _ file fi old?()
dson !false))
repeat
(fi end?(done)
dsoff.
cr (read of fi) eval print.
dson).
fi close.
)
filin (to ev (repeat(cr (read of fi) eval print)))
'Filin basically does a read-eval-print loop, but gets its input from a
file instead of a dispframe.'
to type f t ((:f is string?(
"f _ file f old?(f remove)
!false))
"t_string 30.
repeat(f end?(done) disp_f next into t))
to t fool :: fontname ('dispframe ("defont _ file fontname intostring).'
"disp_dispframe 16 480 514 184 string 520.
disp _ version. "defs _ obset.
to to toAtm (CODE 19 defs_toAtm. toAtm)
to read str (%of?(:str. CODE 2) ! disp read)
PUT USER "DO "(repeat (cr read eval print)). "t_0.)
PUT t "fontname fill string 6
ST8.AL
"version_fill string 34
Welcome to SMALLTALK [May 5]
to quit f s t : : r b (dsoff.
(null :s?()
"f _ file r.
"t _ f intostring.
f reset.
f _ s.
f _ 13.
f _ t.
f close).
file b load)
PUT quit "r fill string 7
REM.CM.
PUT quit "b fill string 5
BOOT.
to os s : : r b ("s _ :.
file b save?
(quit s + r))
PUT os "b fill string 9
BREAK.SV.
PUT os "r fill string 17
;RESUME BREAK.SV.
"fill _ nil
'Then execute...
t. USER
...to install the ST dispframe and start the read-eval-print loop in ST.
When restarting from errors, execute...
disp show. disp frame. USER
'