abcdefghijklmnopqrstuvwxyz0123456789 "#$%'()*+,-./:;<=>@[]_| ABCDEFGHIJKLMNOPQRSTUVWXYZ{^} &?\` Contents: MC ALGOL 68 Transput Model. Version: 1.0. Date: 18-06-1979. Contact: J.C. van Vliet, Mathematisch Centrum, Tweede Boerhaavestraat 49, 1091 AL Amsterdam, The Netherlands. Reference: J.C. van Vliet, ALGOL 68 transput, part II: An implementation model, MC Tract 111, Mathematical Centre, Amsterdam, 1979. Modifications from report: Pseudo-comments are replaced by marked normal comments. The special marks are replaced to fit the character set. See comment in program. Various minor errors in Tract 111 have been corrected: (a+b means: line b on page a) 48+32 {THEN status} => {THEN set logical pos(f); status} 173+ 2 {UPB i OF} => {UPB i1 OF} 188+ 1 {PROC indit} => {PROC #?# indit} 198+10 {(REF INT i) i} => {(REF INT i): i} 204+24 {C := from bin(f, it[k], bin)} => {:= from bin(f, it[k], bin) C} Character positions 1-60 of the first line of this file contain the character set used. Their contents are intended as follows: position repr symbol name 1-26 a..z letters a through z 27-36 0..9 digits zero through nine 37 space 38 " quote 39 # style ii comment 40 $ formatter 41 % percent 42 ' apostrophe 43 ( open 44 ) close 45 * asterisk 46 + plus 47 , comma 48 - minus 49 . point 50 / divided by 51 : colon 52 ; semicolon 53 < is less than 54 = equals 55 > is greater than 56 @ at 57 [ brief sub 58 ] brief bus 59 _ underscore 60 | stick Apostrophes occur only in comments. Character positions 1-29 of the second line of this file contain the characters used for bolding. Their contents are intended as follows: position repr symbol name 1-26 A..Z capital letters A through Z 27 { bold shift 28 ^ bold support 29 } lean shift To obtain the text in point style, replace { and ^ by a point and } by a space. To obtain the text in upper style, delete { and } , and replace ^ by a space. Character positions 1-4 of the third line of this file contain other characters. Their contents are intended as follows: position repr symbol name 1 & ampersand 2 ? question mark 3 \ backslash 4 ` plus i times These characters are used only in strings and comments. ###### {BEGIN {COMMENT Transput model, JC van Vliet, Mathematisch Centrum, Tweede Boerhaavestraat 49, 1091 AL Amsterdam. Version: 790618. The letter-aleph-symbol is replaced by #?#. Bold L, S, K and capital L are replaced by #L#, #S#, #K# and xlx, resp. The text to be duplicated is demarcated by #<# and #>#. {COMMENT # This module publishes the following indicants: {MODE^CHANNEL, {FILE; {CHANNEL stand in channel, stand out channel, stand back channel; {FILE standin, standout, standback; {INT xlx int width, xlx real width, xlx exp width; {PROC estab possible, standconv, get possible, put possible, bin possible, compressible, reset possible, set possible, backspace possible, reidf possible, chan, make conv, make term, on logical file end, on physical file end, on page end, on line end, on format end, on value error, on char error, reidf, establish, create, open, associate, close, lock, scratch, char number, line number, page number, space, backspace, newline, newpage, set, reset, set char number, whole, fixed, float, char in string, put, get, putf, getf, put bin, get bin; # {INT # error numbers # noalter = {SKIP, nobackspace = {SKIP, nobin = {SKIP, nocharpos = {SKIP, noestab = {SKIP, noformat = {SKIP, noline = {SKIP, nomood = {SKIP, nopage = {SKIP, noread = {SKIP, noreset = {SKIP, noset = {SKIP, noshift = {SKIP, notopen = {SKIP, nowrite = {SKIP, posmax = {SKIP, posmin = {SKIP, smallline = {SKIP, wrongbacksp = {SKIP, wrongchar = {SKIP, wrongformat = {SKIP, wrongmult = {SKIP, wrongpos = {SKIP, wrongset = {SKIP, wrongval = {SKIP; {MODE #?# {BOOK = {PSEUDO1 # Some mode, whose values contain at least the following operating-system-dependent information: - the identification string; - some reference to the actual information, and some indication where to read or write the next buffer (see also section 4.4.1); - the logical end of the book ; - information that tells whether the book may again be opened for input or output. ; - the maximum size of the book, as set by 'construct book' (f) or 'find book in system' (e). To avoid excessive copying of information, the implementer is advised to define the mode {BOOK as a reference to the necessary data. #; {MODE #?# {POS = {STRUCT({INT p, l, c); {PRIO #?# {EXCEEDS = 5, {OP^EXCEEDS = ({POS a, b) {BOOL: p {OF a > p {OF b {OR l {OF a > l {OF b {OR c {OF a > c {OF b; {PRIO #?# {BEYOND = 5, {OP^BEYOND = ({POS a, b) {BOOL: {IF p {OF a < p {OF b {THEN^FALSE {ELIF p {OF a > p {OF b {THEN^TRUE {ELIF l {OF a < l {OF b {THEN^FALSE {ELIF l {OF a > l {OF b {THEN^TRUE {ELSE c {OF a > c {OF b {FI; {PROC #?# find book in system = ({STRING idf, {CHANNEL chan, {REF^BOOK book, {REF^BUFFER buffer) {INT: {INT(pseudo2) # If it is possible to "open" (5.2) another file on the given channel at this instant of time, then the pool of available books is searched for a book with the following properties: - the book may be identified by 'idf' and 'chan'; (Note that, in general, 'idf' and 'chan' together identify the book.) - the book may be legitimately accessed through 'chan'; - opening is not inhibited by other users of the book. If such a book is found, it is assigned to 'book', space for a buffer is made available to which 'buffer' is made to refer, and the routine returns 0; the buffer is not initialized. Otherwise, the routine returns some positive integer that corresponds to the appropriate error code. (For a list of these error codes, see section 5.2.) If the maximum size of the book found is not known, some default (for example, the default size of a book linked via the given channel) should be taken instead. #; {PROC #?# construct book = ({INT p, l, c, {STRING idf, {CHANNEL chan, {REF^BOOK book, {REF^BUFFER buffer) {INT: {INT(pseudo3) # 'construct book' starts by checking the validity of its parameters: - it should be possible to "establish" (5.2) another file on the given channel at this instant of time; - 'idf' should be acceptable to the implementation as the identification of a new book; - the size indicated by ('p', 'l', 'c') should not exceed the maximum size allowed for a book linked via the given channel. If one of these checks fails, the routine returns some positive integer that corresponds to the appropriate error code. Otherwise, a book that may be written to is constructed and assigned to 'book'. The book has a text of the size indicated by ('p', 'l', 'c') and an identification string 'idf'. (Note that the identification string stored into the book may not be the whole of 'idf', since in some systems 'idf' might contain information about access rights, record types, etc.) The book is to be accessed via 'chan'. The routine allocates space for a buffer to which 'buffer' is made to refer; the buffer is not filled with information. The logical end of the book is set to (1, 1, 1). Finally, the routine returns 0. 'construct book' is called by 'establish' (5.2.a) #; {PROC #?# default idf = ({CHANNEL chan) {STRING: {STRING(pseudo4) # A default identification string for files which are opened on the given channel via 'create'. Presumably, successive calls of 'default idf' should return different strings. #; {PROC #?# set logical pos = ({REF^FILE f) {VOID: {BEGIN {VOID(pseudo5) # The logical end of the book of 'f' is set to the current position. #; {REF^COVER cover = cover {OF f; c of lpos {OF cover:= c {OF cpos {OF cover; status {OF cover {ANDAB lfe in current line {END; {MODE^CHANNEL = {PSEUDO6 # Some mode, whose values determine at least the following information: - the standard conversion key of the channel (d); - the buffer primitives of the channel (m); - the access properties of the channel (l); - whether or not another file may be "established" (5.2.a) on the channel (c); - the (next) default identification string of a book linked via this channel (4.1.2.g); - the default size of a book linked via this channel (n); - the maximum size of a book linked via this channel (4.1.2.f). #; {MODE #?# {CONV = {STRUCT( {PROC ({REF^FILE, {CHAR) {VOID write char, {PROC ({REF^FILE, {BINCHAR) {VOID write bin char, {PROC ({REF^FILE, {REF^CHAR) {BOOL read char, {PROC ({REF^FILE, {REF^BINCHAR) {VOID read bin char); {PROC estab possible = ({CHANNEL chan) {BOOL: {BOOL(pseudo7) # a routine which returns true if another file may be "established" (5.2.a) on the channel 'chan' #; {PROC standconv = ({CHANNEL chan) {PROC ({BOOK) {CONV: {PROC ({BOOK) {CONV(pseudo8) # a routine which may be used to obtain the default "conversion key"; note that the actual primitives are not obtained until some specific book is provided also #; {CHANNEL stand in channel = {CHANNEL(pseudo9) # a channel value such that for each file successfully opened on this channel, 'get possible' and 'backspace possible' always return true (unless the book linked with the file explicitly indicates otherwise), while the other environment enquiries for files return some suitable values #; {CHANNEL stand out channel = {CHANNEL(pseudo10) # a channel value such that for each file successfully opened on this channel, 'put possible' and 'backspace possible' always return true (unless the book linked with the file explicitly indicates otherwise), while the other environment enquiries for files return some suitable values #; {CHANNEL stand back channel = {CHANNEL(pseudo11) # a channel value such that for each file successfully opened on this channel, 'set possible', 'reset possible', 'get possible', 'put possible', 'bin possible' and 'backspace possible' always return true (unless the book linked with the file explicitly indicates otherwise), while the other environment enquiries for files return some suitable values #; {CHANNEL #?# associate channel = {CHANNEL(pseudo12) # Some channel value which is distinct from all other channel values. It is used by the routine 'associate' (5.2.d) to arrange for a suitable value for the 'channel' field of the file. Note that the various routines that are given a channel value as parameter will have to be able to handle this case also. #; {MODE #?# {POSSIBLES = {BITS; {OP^SAYS = ({POSSIBLES s, t) {BOOL: s >= t; # Some constant declarations. # {POSSIBLES #?# reset poss = 2r 100000000, #?# set poss = 2r 010000000, #?# get poss = 2r 001000000, #?# put poss = 2r 000100000, #?# bin poss = 2r 000010000, #?# compress = 2r 000001000, #?# reidf poss = 2r 000000100, #?# backspace poss = 2r 000000010, #?# system get poss = 2r 000000001, # see section 4.4.1 for the use of this property # #?# associate poss = 2r 111100011; {PROC #?# access methods = ({BOOK book, {CHANNEL chan) {POSSIBLES: {POSSIBLES(pseudo13) # a routine which returns a value of the mode {POSSIBLES from which the available methods of access (immediately after opening) to the book 'book' linked via the channel 'chan' may be determined #; {PROC #?# buffer primitives = ({REF^FILE f) {VOID: {VOID(pseudo14) # The buffer primitives as determined by 'chan {OF f' are assigned to the 'init buffer', 'write buffer', 'do newline', 'do newpage', 'do reset' and 'do set' fields of the cover of 'f'. Note that this routine also has access to the book linked with the file, and thus to the identification string. These may both affect the actual primitives to be incorporated in the file. #; {PROC #?# default size = ({CHANNEL chan) {POS: {POS(pseudo15) # the default size of a book linked via 'chan' #; {MODE^FILE = {STRUCT( {REF^COVER #?# cover, {REF^REF^FORMATLIST #?# piece, {CHARBAG #?# term, {PROC ({REF^FILE, {CHAR) {VOID #?# write char, {PROC ({REF^FILE, {BINCHAR) {VOID #?# write bin char, {PROC ({REF^FILE, {REF^CHAR) {BOOL #?# read char, {PROC ({REF^FILE, {REF^BINCHAR) {VOID #?# read bin char, {PROC ({REF^FILE) {BOOL #?# logical file mended, #?# physical file mended, #?# page mended, #?# line mended, #?# format mended, #?# value error mended, {PROC ({REF^FILE, {REF^CHAR) {BOOL #?# char error mended); {MODE #?# {COVER = {STRUCT( {BOOK book, {CHANNEL chan, {BUFFER buffer, {REF [] [] [] {CHAR text, # for associated files only # {POS cpos, {INT c of lpos, {STATUS status, {INT char bound, {POSSIBLES possibles, {PROC ({REF^FILE) {VOID init buffer, write buffer, do newline, do newpage, do reset, {PROC ({REF^FILE, {INT, {INT, {INT) {VOID do set); {MODE #?# {BUFFER = {PSEUDO16 # Some mode, which probably starts with 'reference to'. A buffer should be able to hold up to 'char bound' characters (possibly, depending on the implementation of conversion keys, in their external (converted) form). #; {PROC get possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS get poss {ELSE error(notopen); abort {FI; {PROC put possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS put poss {ELSE error(notopen); abort {FI; {PROC bin possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS bin poss {ELSE error(notopen); abort {FI; {PROC compressible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS compress {ELSE error(notopen); abort {FI; {PROC reset possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS reset poss {ELSE error(notopen); abort {FI; {PROC set possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS set poss {ELSE error(notopen); abort {FI; {PROC backspace possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS backspace poss {ELSE error(notopen); abort {FI; {PROC reidf possible = ({REF^FILE f) {BOOL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN possibles {OF cover {SAYS reidf poss {ELSE error(notopen); abort {FI; {PROC chan = ({REF^FILE f) {CHANNEL: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN chan {OF cover {ELSE error(notopen); abort {FI; {PROC make conv = ({REF^FILE f, {PROC ({BOOK) {CONV c) {VOID: {IF status {OF cover {OF f {SAYS opened {THEN {VOID(pseudo17) # If possible, the conversion key of 'f' is made to be the result of calling 'c(book {OF cover {OF f)'. Some implementation-dependent tests will probably be needed here: whether the conversion key may be changed might depend on the current and the newly given conversion key, the book, the channel, and other environmental factors. If the conversion key may be changed, the routines in the file that comprise the mode {CONV have to be exchanged. One must take care that the conversion key of an associated file (5.2.d) is not changed. See also Chapter 2 for a discussion of conversion keys and their use. # {ELSE error(notopen); abort {FI; {PROC make term = ({REF^FILE f, {STRING t) {VOID: term {OF f:= {STRINGTOBAG t; {PROC on logical file end = ({REF^FILE f, {PROC ({REF^FILE) {BOOL p) {VOID: logical file mended {OF f:= p; {PROC on physical file end = ({REF^FILE f, {PROC ({REF^FILE) {BOOL p) {VOID: physical file mended {OF f:= p; {PROC on page end = ({REF^FILE f, {PROC ({REF^FILE) {BOOL p) {VOID: page mended {OF f:= p; {PROC on line end = ({REF^FILE f, {PROC ({REF^FILE) {BOOL p) {VOID: line mended {OF f:= p; {PROC on format end = ({REF^FILE f, {PROC ({REF^FILE) {BOOL p) {VOID: format mended {OF f:= p; {PROC on value error = ({REF^FILE f, {PROC ({REF^FILE) {BOOL p) {VOID: value error mended {OF f:= p; {PROC on char error = ({REF^FILE f, {PROC ({REF^FILE, {REF^CHAR) {BOOL p) {VOID: char error mended {OF f:= p; {PROC reidf = ({REF^FILE f, {STRING idf) {VOID: {IF^INT er = {INT(pseudo18) # If the file is opened and the 'idf' field of the book of the cover of the file may be changed, and the 'idf' parameter of the call may be used as the identification of a new book, then the value 0 is returned. Otherwise, some positive integer that corresponds to the appropriate error code is returned. #; er = 0 {THEN {VOID(pseudo19) # the identification string of the book of the cover of 'f' is made to be 'idf' (or some function thereof, in case it contains other auxiliary information which may, for example, affect the 'possibles' field of the cover) # {ELSE error(er); abort {FI; {PROC #?# init buffer = ({REF^FILE f) {VOID: # The precondition of 'init buffer' is: . opened, . {NOT physical file ended, . {NOT page ended, . c {OF cpos {OF cover {OF f = 1. # {BEGIN^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; status {ORAB buffer initialized; {IF possibles {OF cover {SAYS system get poss {AND {NOT (status {SAYS write sequential {OR status {SUGGESTS lfe in current line) {THEN status {ANDAB^NOT write back; buffer {OF cover:= {BUFFER(pseudo20) # The next line from the book of 'f', possibly after conversion (in which case the conversion is done on a line by line basis). Note that a page end may prevent this line from being read. #; charbound {OF cover:= {INT(pseudo21) # the maximum length of the line just (partly) read #; # This length may be zero (e.g., at page end), and it may be greater than the number of characters read if it concerns the last logical line of the file. # c of lpos {OF cover:= {INT(pseudo22) # the position up to which the buffer has been filled by the above read operation # + 1; {IF {BOOL(pseudo23) # the logical end is in the buffer just read # {THEN status {ANDAB lfe in current line; {IF status {SAYS read mood {AND c of lpos {OF cover = 1 {THEN status {ANDAB logical file ended {FI {FI {ELSE # we are writing at the logical end # char bound {OF cover:= {INT(pseudo24) # the maximum length of a line (as recorded in the book), or 0 if the page has overflowed #; c of lpos {OF cover:= 1; status {ORAB write back {FI; {IF {BOOL(pseudo25) # the page of the book has overflowed # # i.e., some marker indicating a page end has been read, or the current line number exceeds the maximum as recorded in the book # {THEN status {ANDAB page end {ELIF char bound {OF cover = 0 {THEN status {ANDAB line end {ELSE status {ORAB not line end {FI {END # init buffer #; {PROC #?# write buffer = ({REF^FILE f) {VOID: # The precondition of 'write buffer' is: . opened, . either write mood or read mood, . the buffer is initialized, . the 'write back' flag is raised, . {NOT physical file ended, . {NOT page ended. # {BEGIN^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; status {ANDAB^NOT write back; # to prevent recursion # c {OF cpos {OF cover:= c {OF cpos {OF cover {MAX c of lpos {OF cover; {IF status {SUGGESTS lfe in current line {AND {NOT (possibles {OF cover {SAYS compress) {THEN {VOID(pseudo26) # Fill the buffer from the position indicated by 'c {OF cpos {OF cover' up to and including the position indicated by 'charbound {OF cover' with spaces (or, in bin mood, some undefined character). #; c {OF cpos {OF cover:= char bound {OF cover + 1 {FI; {VOID(pseudo27) # The contents of the buffer of the file (up to the position indicated by 'c {OF cpos') is, possibly after conversion (in which case the conversion is on a line by line basis), written to the book of the cover of the file. #; {IF {BOOL(pseudo28) # this fails (i.e., the physical end of the book is reached while writing) # {THEN status {ANDAB physical file end; {BUFFER b = buffer {OF cover; # or something else to ensure that the contents of this buffer will not get lost # ensure physical file(f); # observe that the user's event routine will find the current position at the end of the line he is trying to write # {VOID(pseudo29) # try to write 'b' to the (new) book of the cover of 'f' # {FI; {IF status {OF cover {OF f {SUGGESTS lfe in current line {THEN set logical pos(f) {FI {END # write buffer #; {PROC #?# do newline = ({REF^FILE f) {VOID: # The precondition of 'do newline' is: . page ok (see 7.2), . read mood => {NOT lfe in current line. # {BEGIN {IF status {OF cover {OF f {SAYS write back {THEN (write buffer {OF cover {OF f)(f) {FI; {REF^COVER cover = cover {OF f; l {OF cpos {OF cover +:= 1; c {OF cpos {OF cover:= 1; {IF status {OF cover {SAYS write mood {THEN (init buffer {OF cover)(f) {ELSE status {OF cover {ANDAB^NOT buffer initialized {FI {END # do newline #; {PROC #?# do newpage = ({REF^FILE f) {VOID: # The precondition of 'do newpage' is: . physical file ok (see 7.2). # {BEGIN {IF status {OF cover {OF f {SAYS write back {THEN (write buffer {OF cover {OF f)(f) {FI; {REF^COVER cover = cover {OF f; {VOID(pseudo30) # Move to beginning of next page. This may result in compressing the current line and page, or in writing lines full of spaces. #; {IF {BOOL(pseudo31) # this fails to succeed # # i.e., on reading, the logical end is reached while searching for the beginning of the next page; it is assumed that the buffer containing the logical end has been initialized properly # {THEN c {OF cpos {OF cover:= c of lpos {OF cover; status {OF cover {ANDAB logical file ended; newpage(f) # which will immediately lead to a call of the event routine corresponding to 'on logical file end' # {ELSE cpos {OF cover:= (p {OF cpos {OF cover + 1, 1, 1); {IF {BOOL(pseudo32) # this causes the physical end to be reached # # I.e., the current page number exceeds the maximum as recorded in the book. This event can occur only when the file is in write mood. Also, the operating system may be unable to detect it, in which case some subsequent call of 'write buffer' will do so. # {THEN set logical pos(f); status {OF cover {ANDAB physical file end {ELSE status {OF cover {ORAB not page end; {IF status {OF cover {SAYS write mood {THEN (init buffer {OF cover)(f) {ELSE status {OF cover {ANDAB^NOT buffer initialized {FI {FI {FI {END # do newpage #; {PROC #?# do reset = ({REF^FILE f) {VOID: # The precondition of 'do reset' is: . opened, . reset possible. # {BEGIN {IF status {OF cover {OF f {SAYS write back {THEN (write buffer {OF cover {OF f)(f) {FI; {REF^COVER cover = cover {OF f; cpos {OF cover:= (1, 1, 1); {VOID(pseudo33) # The book is physically reset. # {END # do reset #; {PROC #?# do set = ({REF^FILE f, {INT p, l, c) {VOID: # The precondition of 'do set' is: . opened, . set possible. # {IF {IF status {OF cover {OF f {SAYS write back {THEN (write buffer {OF cover {OF f)(f) {FI; {POS(1, 1, 1) {EXCEEDS^POS(p, l, c) {THEN error(posmin); abort {ELIF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; status {ORAB open status; {VOID(pseudo34) # Search for the line indicated by 'p' and 'l'. #; (init buffer {OF cover)(f); {REF^INT ccpos = c {OF cpos {OF cover, {INT char bound = char bound {OF cover; status {SUGGESTS lfe in current line {THEN^INT clpos = c of lpos {OF cover; {IF^BOOL beyond lpos = {POS(p, l, 1) {BEYOND cpos {OF cover {OR c > clpos; beyond lpos {OR c = clpos {THEN^STATUS reading = state(f); ccpos:= clpos; {IF status {SAYS read mood {THEN status {ANDAB logical file ended {ELIF ccpos > char bound {THEN status {ANDAB line end {FI; {IF beyond lpos {THEN^BOOL mended = (logical file mended {OF f)(f); ensure state(f, reading); ({NOT mended | error(wrongset); abort) {FI {ELSE ccpos:= c {FI {ELIF^POS(p, l, 1) {EXCEEDS cpos {OF cover {OR c > char bound + 1 {THEN error(posmax); abort {ELSE ccpos:= c; (ccpos > char bound | status {ANDAB line end) {FI # do set #; {PROC #?# write char = ({REF^FILE f, {CHAR char) {VOID: # The precondition of 'write char' is: . line ok (see 7.2). # {BEGIN^REF^COVER cover = cover {OF f; {VOID(pseudo35) # The character 'char' is (possibly after conversion) written to the buffer of 'cover' at the position indicated by 'c {OF cpos {OF cover'. #; c {OF cpos {OF cover +:= 1; status {OF cover {ORAB write back {END # write char #; {PROC #?# write bin char = ({REF^FILE f, {BINCHAR char) {VOID: # The precondition of 'write bin char' is: . line ok. # {BEGIN^REF^COVER cover = cover {OF f; {VOID(pseudo36) # The binary character 'char' is written to the buffer of 'cover' at the position indicated by 'c {OF cpos {OF cover'. (In binary transput there is no conversion.) #; c {OF cpos {OF cover +:= 1; status {OF cover {ORAB write back {END # write bin char #; {PROC #?# read char = ({REF^FILE f, {REF^CHAR char) {BOOL: # The precondition of 'read char' is: . line ok (see 7.2). # {BEGIN^CHAR c = {CHAR(pseudo37) # The character read (and possibly converted) from the buffer of the cover of 'f' at the position indicated by 'c {OF cpos {OF cover {OF f'. #; c {OF cpos {OF cover {OF f +:= 1; {IF {BOOL(pseudo38) # the conversion succeeds, or no conversion takes place # {THEN char:= c; {TRUE {ELSE^FALSE {FI {END # read char #; {PROC #?# read bin char = ({REF^FILE f, {REF^BINCHAR char) {VOID: # The precondition of 'read bin char' is: . line ok. # {BEGIN char:= {BINCHAR(pseudo39) # The binary character read from the buffer of the cover of 'f' at the position indicated by 'c {OF cpos {OF cover {OF f'. #; c {OF cpos {OF cover {OF f +:= 1 {END # read bin char #; {PROC establish = ({REF^FILE f, {STRING idf, {CHANNEL chan, {INT p, l, c) {INT: {IF^NOT estab possible(chan) {THEN noestab {ELIF^POS(1, 1, 1) {EXCEEDS^POS(p, l, c) {THEN posmin {ELIF^BUFFER buffer, {BOOK book; {INT er = construct book(p, l, c, idf, chan, book, buffer); er /= 0 {THEN er {ELIF^POSSIBLES possibles = access methods(book, chan); {NOT (possibles {SAYS put poss) {THEN nowrite {ELSE {CONV cc = standconv(chan)(book); {STATUS st:= establish status; ({NOT (possibles {SAYS bin poss) | st {ORAB char mood); ({NOT (possibles {SAYS set poss) | st {ORAB not set poss); f:= ({HEAP^COVER:= (book, chan, buffer, {SKIP, # since the 'text' field is never used # {POS(1, 1, 1), # the current position 'cpos' # 1, # c of lpos # st, # status # c, # char bound # possibles, {SKIP, {SKIP, {SKIP, {SKIP, {SKIP, {SKIP # the buffer primitives will be assigned later # ), {REF^REF^FORMATLIST({NIL), # the current format # {STRINGTOBAG "", # terminator string # write char {OF cc, write bin char {OF cc, read char {OF cc, read bin char {OF cc, # the standard conversion key # # the "on routines" all return false initially: # false, false, false, false, false, false, ({REF^FILE f, {REF^CHAR c) {BOOL: {FALSE); buffer primitives(f); 0 {FI # establish #; {PROC create = ({REF^FILE f, {CHANNEL chan) {INT: {BEGIN^POS default = default size(chan); establish(f, default idf(chan), chan, p {OF default, l {OF default, c {OF default) {END # create #; {PROC open = ({REF^FILE f, {STRING idf, {CHANNEL chan) {INT: {IF^BOOK book, {BUFFER buffer; {INT er = find book in system(idf, chan, book, buffer); er /= 0 {THEN er {ELSE^CONV c = standconv(chan)(book); {STATUS st:= open status; {POSSIBLES possibles = access methods(book, chan); ({NOT (possibles {SAYS put poss) | st {ORAB read mood); ({NOT (possibles {SAYS bin poss) | st {ORAB char mood); ({NOT (possibles {SAYS set poss) | st {ORAB not set poss); f:= ({HEAP^COVER:= (book, chan, buffer, {SKIP, # the 'text' field is never used # {POS(1, 1, 1), # the current position 'cpos' # {SKIP, # 'c of lpos' will be initialized by 'init buffer' # st, # status # {SKIP, # 'char bound' will be initialized by 'init buffer' # possibles, {SKIP, {SKIP, {SKIP, {SKIP, {SKIP, {SKIP # the "buffer primitives" will be assigned later # ), {REF^REF^FORMATLIST({NIL), # the current format # {STRINGTOBAG "", # terminator string # write char {OF c, write bin char {OF c, read char {OF c, read bin char {OF c, # the standard conversion key # # on routines: # false, false, false, false, false, false, ({REF^FILE f, {REF^CHAR c) {BOOL: {FALSE); ({NOT (possibles {SAYS get poss) | set write mood(f)); buffer primitives(f); 0 {FI # open #; {PROC associate = ({REF^FILE file, {REF [][][] {CHAR sss) {VOID: {IF^INT lp = {LWB sss, up = {UPB sss; {INT ll = (up >= lp | {LWB sss[lp] | 1), ul = (up >= lp | {UPB sss[lp] | 0); {INT lc = (ul >= ll | {LWB sss[lp][ll] | 1), uc = (ul >= ll | {UPB sss[lp][ll] | 0); lp /= 1 {OR ll /= 1 {OR lc /= 1 {THEN error(wrongmult); abort {ELSE file:= ( {REF^COVER(pseudo40) # a newly created name which is made to refer to the yield of an actual-cover-declarer and whose scope is equal to the scope of 'sss' # := ({SKIP, # the book is not needed # associate channel,# see 4.2.2.h # {SKIP, # the buffer is not used either # sss, # the text, directly accessed by the buffer and conversion primitives # {POS(1, 1, 1), # the current position 'cpos' # uc + 1, # 'c of lpos': this field has to be maintained properly # associate status, # see 6.2.f; note that the buffer is said to be not initialized # uc, # 'char bound': this field has to be maintained properly # associate poss, # see 4.2.2.k # # init buffer # ({REF^FILE f) {VOID: {IF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; status {ORAB buffer initialized; {REF^INT char bound = char bound {OF cover, clpos = c of lpos {OF cover; p {OF cpos {OF cover > {UPB text {OF cover {THEN # file ended # char bound:= 0; clpos:= 1; status {ANDAB (status {SAYS read mood | logical file ended | physical file end) {ELIF l {OF cpos {OF cover > {UPB (text {OF cover)[1] {THEN # page ended # char bound:= 0; clpos:= 1; status {ANDAB page end {ELIF char bound:= {UPB (text {OF cover)[1][1]; (clpos:= char bound + 1) = 1 {THEN status {ANDAB line end {ELSE status {ORAB not line end {FI, # write buffer # {SKIP, # do newline # ({REF^FILE f) {VOID: {BEGIN^REF^COVER cover = cover {OF f; {REF^POS cpos = cpos {OF cover; l {OF cpos +:= 1; c {OF cpos:= 1; (init buffer {OF cover)(f) {END, # do newpage # ({REF^FILE f) {VOID: {BEGIN^REF^COVER cover = cover {OF f; {REF^POS cpos = cpos {OF cover; cpos:= (p {OF cpos + 1, 1, 1); (init buffer {OF cover)(f) {END, # do reset # ({REF^FILE f) {VOID: {BEGIN^REF^COVER cover = cover {OF f; cpos {OF cover:= (1, 1, 1); status {OF cover:= associate status {END, # do set # ({REF^FILE f, {INT p, l, c) {VOID: {IF^POS(1, 1, 1) {EXCEEDS^POS(p, l, c) {THEN error(posmin); abort {ELIF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {INT up = {UPB text {OF cover + 1; {POS lpos = (up + 1, 1, 1), {REF^POS cpos = cpos {OF cover, {REF^INT char bound = char bound {OF cover, clpos = c of lpos {OF cover; status:= associate status {OR buffer initialized {OR (status {AND read or write mood); {NOT (lpos {BEYOND^POS(p, l, c)) # i.e., cpos >= lpos # {THEN^STATUS reading = state(f); cpos:= lpos; char bound:= 0; clpos:= 1; status {ANDAB (status {SAYS read mood | logical file ended | physical file end); {IF^POS(p, l, c) {BEYOND lpos {THEN^BOOL mended = (logical file mended {OF f)(f); ensure state(f, reading); ({NOT mended | error(wrongset); abort) {FI {ELIF # 0 < p <= {UPB text {OF cover # {INT ul = {UPB (text {OF cover)[1] + 1; {INT uc = (ul > 1 | {UPB (text {OF cover)[1][1] + 1 | 1); l > ul {OR c > uc {THEN error(posmax); abort {ELIF cpos:= (p, l, c); char bound:= uc - 1; clpos:= uc; l = ul {THEN status {ANDAB page end {ELIF c = uc {THEN status {ANDAB line end {FI), # end of cover initialization # {REF^REF^FORMATLIST({NIL), # the current format # {STRINGTOBAG "", # terminator string # # write char # ({REF^FILE f, {CHAR char) {VOID: {BEGIN^REF^COVER cover = cover {OF f; {REF^POS cpos = cpos {OF cover; (text {OF cover)[p {OF cpos][l {OF cpos][c {OF cpos] := char; c {OF cpos +:= 1 {END, # write bin char # {SKIP, # read char # ({REF^FILE f, {REF^CHAR char) {BOOL: {BEGIN^REF^COVER cover = cover {OF f; {REF^POS cpos = cpos {OF cover; char:= (text {OF cover)[p {OF cpos][l {OF cpos] [c {OF cpos]; c {OF cpos +:= 1; {TRUE {END, # read bin char # {SKIP, # on routines: # false, false, false, false, false, false, ({REF^FILE f, {REF^CHAR c) {BOOL: {FALSE) {FI # associate #; {PROC #?# false = ({REF^FILE f) {BOOL: {FALSE; {PROC #?# set write mood = ({REF^FILE f) {VOID: # opened and (in general) {NOT write mood # {IF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {NOT (possibles {OF cover {SAYS put poss) {THEN error(nowrite); abort {ELIF status {SAYS read to write not possible {THEN error(noalter); abort {ELSE {IF^NOT (status {SAYS buffer initialized) {THEN (init buffer {OF cover)(f) {FI; status {ANDAB^NOT read mood {ORAB write mood {ORAB logical pos ok; {IF status {SAYS (write sequential {OR not lfe in current line) {THEN set logical pos(f); {VOID(pseudo41) # the size of the current line and page and of all subsequent lines and pages may be expanded (e.g., to the sizes with which the book was originally opened) #; # this pseudo-comment replaces the one in the routine 'put char' of the Revised Report # {IF status {SAYS line ok {THEN status {ORAB write back # since the rest of the line gets lost # {FI {FI {FI # opened & write mood & logical pos ok #; {PROC #?# set read mood = ({REF^FILE f) {VOID: # opened and (in general) {NOT read mood # {IF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {NOT (possibles {OF cover {SAYS get poss) {THEN error(noread); abort {ELIF status {SAYS write to read not possible {THEN error(noalter); abort {ELSE status {ORAB read mood {ANDAB^NOT write mood; {IF status {SUGGESTS lfe in current line {THEN mind logical pos(f) # to trap the case where 'c of lpos <= c {OF cpos' # {FI {FI # opened & read mood #; {PROC #?# set char mood = ({REF^FILE f) {VOID: # opened and (in general) {NOT char mood # {IF^REF^STATUS status = status {OF cover {OF f; status {SAYS bin to char not possible {THEN error(noshift); abort {ELSE status {ORAB char mood {ANDAB^NOT bin mood {FI # opened & char mood #; {PROC #?# set bin mood = ({REF^FILE f) {VOID: # opened and (in general) {NOT bin mood # {IF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {NOT (possibles {OF cover {SAYS bin poss) {THEN error(nobin); abort {ELIF status {SAYS char to bin not possible {THEN error(noshift); abort {ELSE status {ORAB bin mood {ANDAB^NOT char mood {FI # opened & bin mood #; {PROC close = ({REF^FILE f) {VOID: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN {IF status {OF cover {SAYS write back {THEN (write buffer {OF cover)(f) {FI; # note that this may cause a physical file end event # status {OF cover {OF f {ANDAB closed; {VOID(pseudo42) # The information (in the book) on the number of users is updated. Some system-task may be activated to actually close the book; in this case, the book may be re-opened. # {FI; {PROC lock = ({REF^FILE f) {VOID: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN {IF status {OF cover {SAYS write back {THEN (write buffer {OF cover)(f) {FI; status {OF cover {OF f {ANDAB closed; {VOID(pseudo43) # The information on the number of users is updated. Some system-task may be activated to actually lock the book; in this case, it is not possible to re-open the book. # {FI; {PROC scratch = ({REF^FILE f) {VOID: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN {IF status {OF cover {SAYS write back {THEN (write buffer {OF cover)(f) {FI; status {OF cover {OF f {ANDAB closed; {VOID(pseudo44) # The information on the number of users is updated. The book is disposed of in some way by the system. # {FI; {PROC char number = ({REF^FILE f) {INT: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN c {OF cpos {OF cover {ELSE error(notopen); abort {FI; {PROC line number = ({REF^FILE f) {INT: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN l {OF cpos {OF cover {ELSE error(notopen); abort {FI; {PROC page number = ({REF^FILE f) {INT: {IF^REF^COVER cover = cover {OF f; status {OF cover {SAYS opened {THEN p {OF cpos {OF cover {ELSE error(notopen); abort {FI; {MODE #?# {STATUS = {BITS; # The bits in the status have the following meaning (they are numbered from left to right, where the numbers refer to the columns in (f) below): bit 1 = 1 <=> the file is opened; bit 2 = 1 <=> the buffer is initialized; bit 3 = 1 <=> the buffer should ultimately be written back; bit 4 = 1 <=> {NOT line ended; bit 5 = 1 <=> {NOT page ended; bit 6 = 1 <=> {NOT physical file ended; bit 7 = 1 <=> {NOT logical file ended; bit 8 = 1 <=> {NOT lfe in current line; bit 9 = 1 <=> read mood; bit 10 = 1 <=> write mood; bit 11 = 1 <=> char mood; bit 12 = 1 <=> bin mood; bit 13 = 1 <=> {NOT set possible. # {PRIO #?# {ORAB = 1, {OP^ORAB = ({REF^STATUS s, {STATUS t) {REF^STATUS: s:= s {OR t; {PRIO #?# {ANDAB = 1, {OP^ANDAB = ({REF^STATUS s, {STATUS t) {REF^STATUS: s:= s {AND t; {PRIO #?# {SAYS = 5, {OP^SAYS = ({STATUS s, t) {BOOL: s >= t; {PRIO #?# {SUGGESTS = 5, {OP^SUGGESTS = ({STATUS s, t) {BOOL: s <= t; # Some constant-declarations. # {STATUS #?# put char status = 2r 1 00 000 00 0110 0, #?# get char status = 2r 1 00 000 00 1010 0, #?# put bin status = 2r 1 00 000 00 0101 0, #?# get bin status = 2r 1 00 000 00 1001 0, #?# line ok = 2r 1 10 111 10 0000 0, #?# page ok = 2r 1 10 011 10 0000 0, #?# physical file ok = 2r 1 10 001 10 0000 0, #?# logical pos ok = 2r 1 00 000 10 0000 0, #?# logical file ended = 2r 1 11 111 00 1111 1, #*# #?# opened = 2r 1 00 000 00 0000 0, #?# closed = 2r 0 00 000 00 0000 0, #*# #?# buffer initialized = 2r 0 10 000 00 0000 0, #?# write back = 2r 0 01 000 00 0000 0, #?# not lfe in current line = 2r 0 00 000 01 0000 0, #?# lfe in current line = 2r 1 11 111 10 1111 1, #*# #?# line end = 2r 1 11 011 11 1111 1, #*# #?# not line end = 2r 0 10 111 00 0000 0, #?# page end = 2r 1 10 001 11 1111 1, #*# #?# not page end = 2r 0 00 011 00 0000 0, #?# physical file end = 2r 1 10 000 11 1111 1, #*# #?# not set poss = 2r 0 00 000 00 0000 1, #?# write sequential = 2r 0 00 000 00 0100 1, #?# establish status = 2r 1 11 111 10 0100 0, #?# open status = 2r 1 00 111 11 0000 0, #?# associate status = 2r 1 00 111 11 0010 0, #?# read mood = 2r 0 00 000 00 1000 0, #?# write mood = 2r 0 00 000 00 0100 0, #?# char mood = 2r 0 00 000 00 0010 0, #?# bin mood = 2r 0 00 000 00 0001 0, #?# read or write mood = 2r 0 00 000 00 1100 0, #?# not read or write mood = 2r 1 11 111 11 0011 1, #*# #?# read to write not possible = 2r 1 00 000 00 1001 1, #?# write to read not possible = 2r 1 00 000 00 0101 1, #?# bin to char not possible = 2r 1 00 000 00 0001 1, #?# char to bin not possible = 2r 1 00 000 00 0010 1; {PROC #?# mind logical pos = ({REF^FILE f) {VOID: # opened # {IF^REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; status {SAYS not lfe in current line {THEN^SKIP {ELIF c {OF cpos {OF cover >= c of lpos {OF cover {THEN c of lpos {OF cover:= c {OF cpos {OF cover; {IF status {SAYS read mood {THEN status {ANDAB logical file ended {FI {FI # lpos >= cpos #; {PROC space = ({REF^FILE f) {VOID: {IF {IF state(f) {SAYS line ok {THEN^TRUE {ELSE ensure line(f) {FI {THEN # line ok # {REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {REF^INT c = c {OF cpos {OF cover; {IF c < c of lpos {OF cover {THEN (read char {OF f)(f, {LOC^CHAR); {IF c = c of lpos {OF cover {THEN # line end or logical file end # {IF status {SAYS not lfe in current line {THEN status {ANDAB line end {ELIF status {SAYS read mood {THEN status {ANDAB logical file ended {ELIF c > char bound {OF cover {THEN status {ANDAB line end {FI {FI {ELSE # write at logical end # {IF status {SAYS bin mood {THEN (write bin char {OF f)(f, {SKIP) # or something more suitable # {ELSE status {ORAB char mood; # default mood = char mood # (write char {OF f)(f, " ") {FI; (c > char bound {OF cover | status {ANDAB line end) {FI {ELSE error(nocharpos); abort {FI; {PROC backspace = ({REF^FILE f) {VOID: {IF state(f); # to ensure that the mood has been set # {REF^COVER cover = cover {OF f; {NOT (possibles {OF cover {SAYS backspace poss) {THEN error(nobackspace); abort {ELSE mind logical pos(f); # lpos >= cpos # {REF^INT c = c {OF cpos {OF cover; (c > 1 | c -:= 1 | error(wrongbacksp); abort); status {OF cover {ORAB line ok {FI # logical file ok & {NOT line ended #; {PROC newline = ({REF^FILE f) {VOID: {IF {IF state(f) {SAYS page ok {THEN^TRUE {ELSE ensure page(f) {FI {THEN # page ok # {REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {IF status {SUGGESTS lfe in current line {AND status {SAYS read mood {THEN c {OF cpos {OF cover:= c of lpos {OF cover; status {ANDAB logical file ended; newline(f) # which will immediately lead to a call of the event routine corresponding to 'on logical file end' # {ELSE (do newline {OF cover)(f) {FI {ELSE error(noline); abort {FI; {PROC newpage = ({REF^FILE f) {VOID: {IF {IF state(f) {SAYS physical file ok {THEN^TRUE {ELSE ensure physical file(f) {FI {THEN # physical file ok # (do newpage {OF cover {OF f)(f) {ELSE error(nopage); abort {FI; {PROC #?# state = ({REF^FILE f) {STATUS: {IF^STATUS status = status {OF cover {OF f; {NOT (status {SAYS opened) {THEN error(notopen); abort {ELIF status {SUGGESTS not read or write mood {THEN error(nomood); abort {ELSE status {FI # mood ok #; {PROC #?# ensure state = ({REF^FILE f, {STATUS reading) {VOID: {IF^NOT (status {OF cover {OF f {SAYS opened) {THEN error(notopen); abort {ELSE {IF reading {SAYS read mood {THEN set read mood(f) {ELSE set write mood(f) {FI; {IF reading {SAYS char mood {THEN set char mood(f) {ELSE set bin mood(f) {FI {FI; {PROC #?# ensure logical file = ({REF^FILE f) {BOOL: # logical file ended & mood ok # {BEGIN^STATUS old = status {OF cover {OF f; {BOOL mended = (logical file mended {OF f)(f); ensure state(f, old); {REF^STATUS status = status {OF cover {OF f; {IF^NOT (status {SAYS buffer initialized) {THEN (init buffer {OF cover {OF f)(f) {FI; # buffer initialized # {IF status {SAYS logical pos ok {THEN^TRUE {ELIF mended {THEN ensure logical file(f) {ELSE^FALSE {FI {END; {PROC #?# ensure physical file = ({REF^FILE f) {BOOL: # the mood is correct, the file generally not # {IF^REF^STATUS status = status {OF cover {OF f; {IF^NOT (status {SAYS buffer initialized) {THEN (init buffer {OF cover {OF f)(f) {FI; # buffer initialized # {IF status {SAYS logical pos ok {THEN^TRUE {ELSE ensure logical file(f) {FI {THEN # logical file ok # {STATUS old = status {OF cover {OF f; {IF old {SAYS physical file ok {THEN^TRUE {ELSE # physical file ended # {BOOL mended = (physical file mended {OF f)(f); ensure state(f, old); {IF mended {THEN ensure physical file(f) {ELSE error(nopage); abort {FI {FI {ELSE^FALSE {FI; {PROC #?# ensure page = ({REF^FILE f) {BOOL: # the mood is ok, the page generally not # {IF {IF status {OF cover {OF f {SAYS physical file ok {THEN^TRUE {ELSE ensure physical file(f) {FI {THEN # physical file ok # {STATUS old = status {OF cover {OF f; {IF old {SAYS page ok {THEN^TRUE {ELSE # page ended # {BOOL mended = (page mended {OF f)(f); ensure state(f, old); ({NOT mended | newpage(f)); ensure page(f) {FI {ELSE^FALSE {FI; {PROC #?# ensure line = ({REF^FILE f) {BOOL: # the mood is ok, the line generally not # {IF {IF status {OF cover {OF f {SAYS page ok {THEN^TRUE {ELSE ensure page(f) {FI {THEN # page ok # {STATUS old = status {OF cover {OF f; {IF old {SAYS line ok {THEN^TRUE {ELSE # line ended # {BOOL mended = (line mended {OF f)(f); ensure state(f, old); ({NOT mended | newline(f)); ensure line(f) {FI {ELSE^FALSE {FI; {PROC #?# next pos = ({REF^FILE f) {VOID: # the mood is ok, the line is not # {IF^NOT ensure line(f) {THEN error(nocharpos); abort {FI # line ok #; {PROC #?# check pos = ({REF^FILE f) {BOOL: # the mood is ok, the line generally not # {IF {IF status {OF cover {OF f {SAYS page ok {THEN^TRUE {ELSE ensure page(f) {FI {THEN # page ok # {STATUS old = status {OF cover {OF f; {IF old {SAYS line ok {THEN^TRUE {ELSE # line ended # {BOOL mended = (line mended {OF f)(f); ensure state(f, old); (mended | check pos(f) | {FALSE) {FI {ELSE^FALSE {FI; {PROC set = ({REF^FILE f, {INT p, l, c) {VOID: {IF^NOT set possible(f) {THEN error(noset); abort {ELSE mind logical pos(f); # lpos >= cpos # (do set {OF cover {OF f)(f, p, l, c) {FI; {PROC reset = ({REF^FILE f) {VOID: {IF^NOT reset possible(f) {THEN error(noreset); abort {ELSE mind logical pos(f); # lpos >= cpos # (do reset {OF cover {OF f)(f); {REF^COVER cover = cover {OF f; {POSSIBLES possibles = possibles {OF cover, {REF^STATUS st = status {OF cover:= open status; ({NOT (possibles {SAYS put poss) | st {ORAB read mood); ({NOT (possibles {SAYS bin poss) | st {ORAB char mood); ({NOT (possibles {SAYS set poss) | st {ORAB not set poss); ({NOT (possibles {SAYS get poss) | set write mood(f)) {FI; {PROC set char number = ({REF^FILE f, {INT c) {VOID: {IF^REF^COVER cover = cover {OF f; {IF^NOT (state(f) {SAYS buffer initialized) {THEN (init buffer {OF cover)(f) {ELSE mind logical pos(f) {FI; c >= 1 {AND c < c of lpos {OF cover {THEN # handle simple case # {IF c < c {OF cpos {OF cover {AND {NOT (possibles {OF cover {SAYS backspace poss) {THEN error(nobackspace); abort {FI; c {OF cpos {OF cover:= c; status {OF cover {ORAB line ok {ELSE {WHILE^INT ccpos = c {OF cpos {OF cover {OF f; ccpos /= c {DO {IF c < 1 {OR c > char bound {OF cover {OF f + 1 {THEN error(wrongpos); abort {ELIF c > ccpos {THEN space(f) {ELSE backspace(f) {FI {OD {FI; {MODE #?# {NUMBER = {UNION(#<##L# {REAL#>#, #<##L# {INT#>#); {PROC whole = ({NUMBER v, {INT width) {STRING: {CASE v {IN ({UNION(#<##L# {INT#>#) x): ({INT abs width = {ABS width; {INT upb = abs width {MAX^INTWIDTH x; {INT lwb:= upb - abs width + 1; {INT first:= lwb, [0 : upb] {CHAR s; {IF^BOOL neg = subwhole(x, first, upb, s); neg {OR width > 0 {THEN s[first -:= 1]:= (neg | "-" | "+") {FI; # the converted number (including a possible sign) is stored in 's[first : ]', while the elements 's[lwb {MAX 0]' ... 's[first-1]' contain spaces # (width = 0 | lwb:= first); # no leading spaces needed # {IF first >= lwb {THEN s[lwb : ] {ELSE abs width * errorchar {FI) {OUT fixed(v, width, 0) {ESAC; {PROC fixed = ({NUMBER v, {INT width, after) {STRING: {IF^INT abs width = {ABS width, {BOOL poswidth = width > 0, zerowidth = width = 0; {INT point:= log10(v) - 1, length:= abs width - {ABS poswidth; # there will be either 'point' or 'point+1' digits before the decimal point # after < 0 {OR {NOT zerowidth {AND (after >= length {OR point > length) # a partial test for the correctness of the parameters # {THEN 1 {MAX abs width * errorchar {ELIF^INT aft = (zerowidth | after | after {MIN (length - point)); # now aft equals the maximum number of digits to be delivered after the decimal point # {INT upb = point + aft + 3; [0 {MIN (upb - abs width) - 2 : upb] {CHAR s; {BOOL neg = subfixed(v, aft, point, s, {FALSE); # 's[1 : point + aft + 1]' contains the relevant digits, 's[point]' = ".", s[0] = "0" # {INT last:= point + aft, first:= 1, rp; {IF zerowidth {THEN length:= last {ELSE length:= abs width - {ABS(neg {OR poswidth); last:= last {MIN length {FI; # 'last' is the index of the last character that can be returned; 'length' is the total space available for digits and decimal point # {IF power10(s, rp, last) {THEN first:= 0; ({NOT zerowidth {AND last = length | last -:= 1) # decrement 'last' because of rounding # {FI; (last = point | last -:= 1); # the result should not end with "." # (point = 1 {AND last < length | first:= 0); # deliver "0" or "0.xxx" # point > last + 1 {OR last < first # definitive test for the correctness of the parameters # {THEN abs width * errorchar {ELSE s[first - 1]:= (neg | "-" |: poswidth | "+" | " "); round(s, rp, last); s[(zerowidth | first - {ABS neg | last - abs width + 1) : last] {FI; {PROC float = ({NUMBER v, {INT width, after, exp) {STRING: {IF^INT abs width = {ABS width, sign after = {SIGN after, {INT exp places:= {ABS exp; {INT last:= abs width - exp places - 2; {INT before:= last - after - sign after; {SIGN before + sign after <= 0 # partial test for correctness of parameters # {THEN 1 {MAX abs width * errorchar {ELIF^INT first:= 1, exponent:= before, rp:= last + 1; [-1 : abs width - sign after] {CHAR s, {BOOL exp sign = exp > 0; {BOOL neg:= subfixed(v, after, exponent, s, {TRUE); # 's[1 : before + after + 2]' contains the relevant digits, 's[before + 1]' = "." # exponent -:= before; # now 'exponent' is the real exponent # {WHILE {IF rp > last {THEN {IF power10(s, rp, last) {THEN first:= 0; s[before]:= "."; s[before + 1]:= (before = 0 | rp:= 1; "0" | "9"); before -:= 1; last -:= 1; exponent +:= 1 {FI # move the decimal point one place to the left and adjust the various parameters # {FI; exp sign {EXPLENGTH exponent > exp places {AND last >= first # the exponent does not fit and it is still possible to sacrifice digits # {DO last -:= 1; exp places +:= 1; {CASE^SIGN(last - before - 1) + 2 {IN (before -:= 1; exponent +:= 1), # "after" = 0, so decrement 'before' # (before +:= 1; exponent -:= 1; {REF^CHAR sb1 = s[before + 1]; s[before]:= sb1; sb1:= ".") # "after":= 0, so the decimal point also disappears; as a consequence, 'before' can be incremented # # {OUT "after" is decremented, but still greater than 0 # {ESAC {OD; last < first # no digits left in mantissa # {THEN abs width * errorchar {ELSE round(s, rp, last); {INT p:= first; {WHILE s[p] = "0" {AND s[p + 1] /= "." {AND p < last {DO s[p]:= " "; p +:= 1 {OD; # change "000.00" to " 0.00" # s[p - 1]:= (neg | "-" |: width > 0 | "+" | " "); s[last +:= 1]:= "e"; {INT l = last + exp places; # convert exponent into 's[last + 1 : l]': # neg:= subwhole(exponent, last +:= 1, l, s); (neg {OR exp sign | s[last - 1]:= (neg | "-" | "+")); # place sign of exponent # s[first - 1 : l] {FI; {PROC #?# subwhole = ({UNION(#<##L# {INT#>#) x, {REF^INT first, {INT upb, {REF [] {CHAR s) {BOOL: # The digits of 'x' are placed in 's' (right justified to the position with index 'upb'); the result will be a boolean indicating the sign of 'x'. As a result, 'first' will point to the first digit of 'x' in 's'. Leading spaces will be placed from position F onwards, where F is the initial value of 'first'. # {CASE x {IN #<#(#L# {INT x): {BEGIN #L# {INT n:= {ABS x, {INT f = first; first:= upb + 1; {WHILE s[first -:= 1]:= dig char(#S#(n {MOD #L# 10)); n {OVERAB #L# 10; n /= #L# 0 {DO^SKIP^OD; {FOR i {FROM f {TO first - 1 {DO s[i]:= " " {OD; x < #L# 0 {END#># {ESAC; {PROC #?# subfixed = ({NUMBER v, {INT after, {REF^INT p, {REF [] {CHAR s, {BOOL floating) {BOOL: {BOOL(pseudo45) # A unit which, given values V, {AFTER and {FLOATING (where {AFTER is at least zero), yields a value B and makes 'p' and 's' refer to values P and S, respectively, such that: o B is true if V is negative, and false otherwise; o For all i from {LWB S to -1, S[i] = " "; o S[0] = "0"; o Case A: {FLOATING is false: o it maximizes P-1 U M = c[i] * 10]P-1-i[ + c[i] * 10]P-i[ i=1 i=P+1 under the following constraints: o If |V| >= 1.0, then P = {ENTIER(log[10](|V|)) + 2, and, otherwise, P = 1; o U = P + {AFTER + 1; o M <= |V|; o S[ P] = "."; o For all i from 1 to U, if i /= P, then 0 <= c[i] <= 9, and S[i] = 'dig char(c[i])'. Case B: {FLOATING is true: o it maximizes Q U M = c[i] * 10]Q-i[ + c[i] * 10]Q+1-i[ i=1 i=Q+2 under the following constraints: o Q is the initial value of 'p' ; o If V = 0, then P = 1, and, otherwise, P = {ENTIER(log[10](|V|))+1 ; o U = Q + after + 2; o M <= |V| * 10]Q- P[; o S[ Q + 1] = "."; o For all i from 1 to U, if i /= Q + 1, then 0 <= c[i] <= 9, and S[i] = 'dig char(c[i])'. #; {PROC #?# log10 = ({NUMBER v) {INT: {INT(pseudo46) # A number P such that, given a value V, P = 0 if |V| < 1.0, and, if |V| >= 1.0, then P is such that {ENTIER(log[10](|V|)) + 1 <= P <= {ENTIER(log[10](|V|)) + 2. Thus, P is an estimate of the number of digits in the integral part of V; this estimate may be at most 1 too large. This definition should allow efficient computation of P; e.g., using the normal floating point representation of V with a mantissa M and base 2 exponent E (E = {ENTIER(log[2]|V| )), P may be given the value ({ENTIER(log[10]2 * (E+1))+1) {MAX 0. Obviously also, 'log10' is a typical candidate for inline expansion. #; {PRIO #?# {EXPLENGTH = 9; {OP^EXPLENGTH = ({BOOL sign, {INT exp) {INT: {INT(pseudo47) # The smallest E such that 'whole(exp, {ABS sign * E)' succeeds. This operator is used to estimate the length needed to convert the exponent in 'float'. This is probably easier and faster than actually converting the exponent and subsequently testing its width, since on most implementations the exponent will be a relatively small integer (<= 322, say). #; {PROC #?# power10 = ({REF [] {CHAR s, {REF^INT rp, {INT last) {BOOL: {IF rp:= last + 1; {CHAR c:= s[rp]; char dig((c = "." | s[rp + 1] | c)) >= 5 {THEN {WHILE c:= s[rp -:= 1]; c = "9" {OR c = "." {DO^SKIP^OD; rp = 0 {ELSE^FALSE {FI; {PROC #?# round = ({REF [] {CHAR s, {INT rp, last) {VOID: {IF rp <= last {THEN^REF^CHAR srp = s[rp]; srp:= dig char(char dig(srp)+1); {FOR i {FROM rp + 1 {TO last {DO^REF^CHAR si = s[i]; (si /= "." | si:= "0") {OD {FI; {PROC #?# dig char = ({INT x) {CHAR: "0123456789abcdef"[x+1]; {PRIO #?# {MAX = 9; {OP^MAX = ({INT a, b) {INT: (a > b | a | b); {PRIO #?# {MIN = 9; {OP^MIN = ({INT a, b) {INT: (a < b | a | b); {PRIO #?# {ADD = 1; {OP #<# {ADD = ({REF #L# {INT a, {INT d) {BOOL: {IF #L# {INT amax = xlx max int {OVER #L# 10, dmax = xlx max int {MOD #L# 10; a > amax {OR a = amax {AND #K# d > dmax {THEN^FALSE {ELSE a:= #L# 10 * a + #K# d; {TRUE {FI #>#; {PROC #?# string to l real = ({REF [] {CHAR s, {INT exp, {BOOL neg, {UNION(#<#{REF #L# {REAL#>#) x) {BOOL: {BOOL(pseudo48) # A unit which, given values S, {EXP and {NEG, yields a value B such that: o Let M be equal to {UPB S c[i] * 10]{UPB S - i[ * 10]{EXP[, i={LWB S where, for all i from {LWB S to {UPB S, c[i] = 'char dig(S[i])'; o {IF M <= xlx max real, then: o 'x' is made to refer to a value X, where X is "close" to M * ({NEG | -1 | 1); o B is true; Otherwise, o B is false . #; {PROC #?# char dig = ({CHAR x) {INT: ({INT i; char in string(x, i, "0123456789abcdef"); i-1); {PROC char in string = ({CHAR c, {REF^INT i, {STRING s) {BOOL: ({BOOL found:= {FALSE; {FOR k {FROM^LWB s {TO^UPB s {WHILE^NOT found {DO (c = s[k] | i:= k; found:= {TRUE) {OD; found); {INT #<# xlx int width = # the smallest integral value such that 'xlx max int' may be converted without error using the pattern n(xlx int width)d # ({INT c:= 1; {WHILE #L# 10 ** (c-1) < xlx max int {OVER #L# 10 {DO c +:= 1 {OD; c) #>#; {INT #<# xlx real width = {INT(pseudo49) # the smallest integral value such that different values yield different strings using the pattern d.n(xlx real width - 1)d # #>#; {INT #<# xlx exp width = {INT(pseudo50) # the smallest integral value such that 'xlx max real' may be converted without error using the pattern d.n(xlx real width - 1)d e n(xlx exp width)d # #>#; {OP #?# {INTWIDTH = ({UNION(#<##L# {INT#>#) x) {INT: {CASE x {IN #<#(#L# {INT): xlx int width#># {ESAC; {OP #?# {REALWIDTH = ({UNION(#<##L# {REAL#>#) x) {INT: {CASE x {IN #<#(#L# {REAL): xlx real width#># {ESAC; {OP #?# {RREALWIDTH = ({UNION(#<#{REF #L# {REAL#>#) x) {INT: {CASE x {IN #<#({REF #L# {REAL): xlx real width#># {ESAC; {OP #?# {EXPWIDTH = ({UNION(#<##L# {REAL#>#) x) {INT: {CASE x {IN #<#(#L# {REAL): xlx exp width#># {ESAC; {MODE #?# {SIMPLOUT = {UNION(#<# #L# {INT #>#, #<# #L# {REAL #>#, #<# #L# {COMPL #>#, {BOOL, #<# #L# {BITS #>#, {CHAR, [] {CHAR); {MODE #?# {OUTTYPE = {UNION({PSEUDO51, {SIMPLOUT, {STRING, {STRUCT({PROC^OUTTYPE outtype)) # {OUTTYPE:: union of {OUTTYPERS mode. {OUTTYPERS:: {OUTTYPER; {OUTTYPER^OUTTYPERS. {OUTTYPER:: {PLAIN; structured with {OUTTAGS mode; {ROWS of {OUTTYPER. {OUTTAGS:: {OUTTYPER field {TAG; {OUTTYPER field {TAG^OUTTAGS. #; {MODE #?# {SIMPLIN = {UNION(#<# {REF #L# {INT #>#, #<# {REF #L# {REAL #>#, #<# {REF #L# {COMPL #>#, {REF^BOOL, #<# {REF #L# {BITS #>#, {REF^CHAR, {REF [] {CHAR, {REF {STRING); {MODE #?# {INTYPE = {UNION({PSEUDO52, {SIMPLIN, {STRUCT({PROC^INTYPE intype)) # {INTYPE:: union {OF^INTYPERS mode. {INTYPERS:: reference to {INTYPER; reference to {INTYPER^INTYPERS. {INTYPER:: {PLAIN; flexible row of character; structured with {INTAGS mode; {ROWS of {INTYPER. {INTAGS:: {INTYPER field {TAG; {INTYPER field {TAG^INTAGS. #; {OP #?# {STRAIGHTOUT = ({OUTTYPE x) [] {SIMPLOUT: [] {SIMPLOUT(pseudo53) # the result of "straightening" 'x' #; {OP #?# {STRAIGHTIN = ({INTYPE x) [] {SIMPLIN: [] {SIMPLIN(pseudo54) # the result of "straightening" 'x' #; {PROC put = ({REF^FILE f, [] {UNION({OUTTYPE, {PROC ({REF^FILE) {VOID) x) {VOID: {BEGIN {IF^NOT (status {OF cover {OF f {SAYS put char status) {THEN ensure state(f, put char status) {FI; {FOR i {TO^UPB x {DO {CASE x[i] {IN ({PROC ({REF^FILE) {VOID pf): (pf(f); {IF i < {UPB x {THEN {IF^NOT (status {OF cover {OF f {SAYS put char status) {THEN ensure state(f, put char status) {FI {FI), ({OUTTYPE ot): {BEGIN [] {SIMPLOUT y = {STRAIGHTOUT ot; {PROC l real conv = ({REF [] {CHAR s, {UNION(#<##L# {REAL#>#) x) {VOID: # this routine converts 'x' into s[0 : xlx real width + xlx exp width + 3] # {BEGIN^INT exponent:= 1, rp, last:= {REALWIDTH x + 1; {BOOL neg = subfixed(x, last - 2, exponent, s, {TRUE); # now 's' = "0x.xxxx..." # exponent -:= 1; {IF power10(s, rp, last) {THEN s[1]:= "1"; s[2]:= "."; {FOR i {FROM 3 {TO last {DO s[i]:= "0" {OD; exponent +:= 1 {ELSE round(s, rp, last) {FI; s[0]:= (neg | "-" | "+"); s[last +:= 1]:= "e"; last +:= 1; {BOOL expneg = subwhole(exponent, last, last + {EXPWIDTH x, s); # convert exponent into tail of 's' # s[last - 1]:= (expneg | "-" | "+") {END; {FOR j {TO^UPB y {DO {CASE y[j] {IN ({UNION({NUMBER, #<##L# {COMPL#>#) nc): {BEGIN {INT upb = {CASE nc {IN #<#(#L# {INT): xlx int width#>#, #<#(#L# {REAL): xlx real width + xlx exp width + 3#>#, #<#(#L# {COMPL): 2 * xlx real width + 2 * xlx exp width + 9#># {ESAC; [0 : upb] {CHAR s; {WHILE {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; {REF^COVER cover = cover {OF f; {IF upb >= char bound {OF cover {THEN error(smallline); abort {FI; # the number would not fit on the line, even if it were empty # c {OF cpos {OF cover + upb + {SIGN(c {OF cpos {OF cover - 1) > char bound {OF cover # the number does not fit on the remainder of the line # {DO^BOOL mended = (line mended {OF f)(f); ensure state(f, put char status); ({NOT mended | newline(f)) {OD; {IF c {OF cpos {OF cover {OF f /= 1 {THEN (write char {OF f)(f, " ") {FI; # a number is preceded by one space if not at the start of a line # {CASE nc {IN ({UNION(#<##L# {INT#>#) k): {BEGIN^INT first:= 0; {BOOL neg = subwhole(k, first, upb, s); s[first - 1]:= (neg | "-" | "+") {END, ({UNION(#<##L# {REAL#>#) r): l real conv(s, r), #<#(#L# {COMPL z): {BEGIN l real conv(s, re {OF z); {INT istart = upb {OVER 2; s[istart]:= " "; s[istart + 1]:= "i"; l real conv(s[istart + 2 : @ 0], im {OF z) {END#># {ESAC; {FOR k {FROM 0 {TO upb {DO (write char {OF f)(f, s[k]) {OD; {REF^COVER cover = cover {OF f; {IF c {OF cpos {OF cover > char bound {OF cover {THEN status {OF cover {ANDAB line end {FI # test line end # {END # numeric #, ({BOOL b): {BEGIN {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; put char(f, (b | flip | flop)) {END, #<#(#L# {BITS lb): {FOR k {TO xlx bits width {DO {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; put char(f, (k {ELEM lb | flip | flop)) {OD#>#, ({CHAR k): {BEGIN {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; put char(f, k) {END, ([] {CHAR ss): {BEGIN {IF^NOT (status {OF cover {OF f {SAYS page ok) {THEN ensure page(f) {FI; {INT from:= {LWB ss, to; {WHILE from <= {UPB ss {DO {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; {REF^COVER cover = cover {OF f; {FOR k {FROM from {TO to:= (from + char bound {OF cover - c {OF cpos {OF cover) {MIN^UPB ss {DO (write char {OF f)(f, ss[k]) {OD; from:= to + 1; {IF c {OF cpos {OF cover > char bound {OF cover {THEN status {OF cover {ANDAB line end {FI # test line end # {OD {END {ESAC {OD {END {ESAC {OD {END; {PROC #?# put char = ({REF^FILE f, {CHAR char) {VOID: # the precondition of 'put char' is: . line ok (see 7.2) # {BEGIN (write char {OF f)(f, char); {REF^COVER cover = cover {OF f; {IF c {OF cpos {OF cover > char bound {OF cover {THEN status {OF cover {ANDAB line end {FI # test line end # {END; {PROC get = ({REF^FILE f, [] {UNION({INTYPE, {PROC ({REF^FILE) {VOID) x) {VOID: {BEGIN {IF^NOT (status {OF cover {OF f {SAYS get char status) {THEN ensure state(f, get char status) {FI; {FOR i {TO^UPB x {DO {CASE x[i] {IN ({PROC ({REF^FILE) {VOID pf): (pf(f); {IF i < {UPB x {THEN {IF^NOT (status {OF cover {OF f {SAYS get char status) {THEN ensure state(f, get char status) {FI {FI), ({INTYPE it): {BEGIN [] {SIMPLIN y = {STRAIGHTIN it, {CHAR k; {PROC mend char = ({CHARBAG s, {CHAR sugg) {VOID: # the character read is not in 's'; therefore, the event routine corresponding to 'on char error' is called with with the suggestion 'sugg' # {IF k:= sugg; {BOOL ok = {IF (char error mended {OF f)(f, k) {THEN char in bag(k, s) {ELSE^FALSE {FI; ensure state(f, get char status); {IF^NOT (status {OF cover {OF f {SAYS buffer initialized) {THEN (init buffer {OF cover {OF f)(f) {FI; {NOT ok {THEN error(wrongchar); k:= sugg {FI; {PROC skip initial spaces = {VOID: # skip spaces, in the meantime passing to a next line and/or page, if necessary # {WHILE {IF^NOT(status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; get char(f, k); k = " " {DO^SKIP^OD; {PROC skip spaces = {VOID: # only spaces on the current line are skipped # {WHILE {IF status {OF cover {OF f {SAYS line ok {THEN get char(f, k); k = " " {ELSE (check pos(f) | get char(f, k) | error(nocharpos); abort); {FALSE {FI {DO^SKIP^OD; {OP^NODIGIT = ({CHAR c) {BOOL: {NOT char in bag(c, radix10digit); # in-line code # #<#{PROC read xlx integer = ({REF #L# {INT i) {BOOL: # if an integer is read successfully, it is assigned to 'i', and the routine returns true; otherwise, it returns false # {BEGIN^BOOL ok:= {TRUE, {BOOL neg = k = "-"; (neg {OR k = "+" | skip spaces); ({NODIGIT k | mend char(radix10digit, "0")); #L# {INT j:= #K# chardig(k); {WHILE {IF status {OF cover {OF f {SAYS line ok {THEN get char(f, k); {IF^NODIGIT k {THEN backchar(f); {FALSE {ELSE (ok | ok:= j {ADD chardig(k)); {TRUE {FI {ELSE^FALSE {FI {DO^SKIP^OD; {IF ok {THEN i:= (neg | -j | j) {FI; ok {END#>#; {PROC read l real = ({UNION(#<#{REF #L# {REAL#>#) r) {BOOL: # similar to 'read xlx integer', for real numbers # {BEGIN^BOOL ok:= {TRUE, {BOOL neg = k = "-", {INT lrw = {RREALWIDTH r; (neg {OR k = "+" | skip spaces); [0 : lrw] {CHAR s, {INT index:= -1, exp:= 0, {BOOL sig:= {FALSE; # and remains false until the first significant digit is found # {PROC read digits = ({BOOL after) {VOID: # Read a sequence of digits (from either the integral or the fractional part, depending on the value of the 'after' parameter). At most 'xlx real width+1' digits are stored in 's'. 'exp' counts the distance from the decimal point to the first significant digit. If 'after' is false, then 'i' = 0, so 'exp' is just incremented for each significant digit read. If 'after' is true, then 'i' = -1, and 'exp' is decremented as long as non-significant digits are read after the decimal point. # {BEGIN^INT i = {ABS after; ({NODIGIT k | mend char(radix10digit, "0")); {WHILE {IF^NODIGIT k {THEN^FALSE {ELIF {IF sig:= sig {OR k /= "0" {THEN (index < lrw | s[index +:= 1]:= k | exp +:= 1) {FI; exp -:= i; status {OF cover {OF f {SAYS line ok {THEN get char(f, k); {TRUE {ELSE^FALSE {FI {DO^SKIP^OD {END; {IF k /= "." {THEN read digits({FALSE) {FI; # if this call of 'read digits' has exhausted the line, then 'k' is some digit at this point, so the next test fails # {IF k = "." {THEN {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN get char(f, k) {ELSE error(nocharpos); abort {FI; read digits({TRUE) {FI; # again, if the line is exhausted, then 'k' is some digit at this point # {IF char in bag(k, times ten to the power) {THEN^INT e; skip spaces; ok:= read integer(e); {IF ok:= ok {AND ({SIGN e /= {SIGN exp {OR^ABS e <= max int - {ABS exp) # test for integral overflow of exponent # {THEN exp +:= e {FI {ELSE back char(f) {FI; {IF^NOT ok {THEN^FALSE {ELSE string to l real(s[ : index], exp, neg, r) {FI {END; {FOR j {TO^UPB y {DO {CASE y[j] {IN ({UNION(#<#{REF #L# {INT#>#, #<#{REF #L# {REAL#>#, #<#{REF #L# {COMPL#>#) irc): {BEGIN skip initial spaces; {IF^NOT {CASE irc {IN #<#({REF #L# {INT ii): read xlx integer(ii)#>#, ({UNION(#<#{REF #L# {REAL#>#) rr): read l real(rr), #<#({REF #L# {COMPL zz): {BEGIN {BOOL ok = read l real(re {OF zz); skip spaces; {IF^NOT char in bag(k, plus i times) {THEN mend char(plus i times, "i") {FI; skip spaces; ok {AND read l real(im {OF zz) {END#># {ESAC {THEN^BOOL mended = (value error mended {OF f)(f); ensure state(f, get char status); ({NOT mended | error(wrongval); abort) {FI {END, ({REF^BOOL bb): {BEGIN skip initial spaces; {IF^NOT char in bag(k, flipflop) {THEN mend char(flipflop, flop) {FI; bb:= k = flip {END, #<#({REF #L# {BITS lb): {BEGIN [1 : xlx bits width] {BOOL b; {FOR i {TO xlx bits width {DO skip initial spaces; {IF^NOT char in bag(k, flipflop) {THEN mend char(flipflop, flop) {FI; b[i]:= k = flip {OD; lb:= xlx bits pack(b) {END#>#, ({REF^CHAR cc): {BEGIN {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; get char(f, cc) {END, ({REF [] {CHAR ss): {BEGIN {IF^NOT (status {OF cover {OF f {SAYS page ok) {THEN ensure page(f) {FI; {FOR i {FROM^LWB ss {TO^UPB ss {DO {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; get char(f, ss[i]) {OD {END, ({REF^STRING ss): {BEGIN {IF^NOT (status {OF cover {OF f {SAYS buffer initialized) {THEN (init buffer {OF cover {OF f)(f) {FI; {INT index:= 0, upbs:= char bound {OF cover {OF f - c {OF cpos {OF cover {OF f + 1; {STRING s:= {LOC [1 : upbs] {CHAR; {WHILE {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN get char(f, k); {IF char in bag(k, term {OF f) {THEN back char(f); {FALSE {ELSE^TRUE {FI {ELSE^FALSE {FI {DO {IF index = upbs {THEN {INT u = char bound {OF cover {OF f - c {OF cpos {OF cover {OF f + 2; # the number of characters from the current position onwards; note that 'u' > 0, since 'c {OF cpos' <= 'char bound + 1' # upbs +:= u; s +:= {LOC [1 : u] {CHAR {FI; # estimate new 's' # s[index +:= 1]:= k {OD; ss:= s[: index] {END {ESAC {OD {END {ESAC {OD {END; {PROC #?# get char = ({REF^FILE f, {REF^CHAR char) {VOID: char:= {IF^CHAR k; {BOOL conv ok = (read char {OF f)(f, k); {REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {IF c {OF cpos {OF cover = c of lpos {OF cover {THEN # line and/or logical file ended # status {ANDAB {IF status {SUGGESTS lfe in current line {THEN logical file ended {ELSE line end {FI {FI; conv ok {THEN k {ELIF^CHAR sugg:= " "; {BOOL mended = (char error mended {OF f)(f, sugg); ensure state(f, get char status); mended {THEN sugg {ELSE error(wrongchar); " " {FI; {PROC #?# back char = ({REF^FILE f) {VOID: {VOID(pseudo55) # If the current position is not at the beginning of a buffer, it is set back over one position; otherwise, an error message is given and the elaboration of the particular program is aborted. (This can only be caused by a call of the event routine corresponding to 'on char error' while reading a string; this call must then have caused the current position to be moved to the first position of a new buffer, returning a character from the terminator string of 'f'. This case is assumed to be exceedingly rare.) Note that no more than one call of 'back char' can occur for each item read. So even if 'backspace possible' returns false, 'back char' still works. #; {MODE #?# {CHARBAG = {PSEUDO56 # Some mode which allows efficient retrieval of information as to the presence or absence of a given character in a given set (for example, a bit string). #; {OP #?# {STRINGTOBAG = ({STRING s) {CHARBAG: {CHARBAG(pseudo57) # The string in 's' is converted to a corresponding value of the mode specified by {CHARBAG. #; {PROC #?# char in bag = ({CHAR k, {CHARBAG s) {BOOL: {BOOL(pseudo58) # This routine returns true if the character 'k' is contained in 's', and false otherwise. #; {PRIO #?# {MERGEWITH = 6, {OP^MERGEWITH = ({CHARBAG s, t) {CHARBAG: {CHARBAG(pseudo59) # A value K of the mode {CHARBAG is delivered, such that the set of characters in K is the union of the sets of characters in 's' and 't'. #; {CHARBAG #?# radix10digit = {STRINGTOBAG "0123456789", #?# radix 2digit = {STRINGTOBAG "01", #?# radix 4digit = {STRINGTOBAG "0123", #?# radix 8digit = {STRINGTOBAG "01234567", #?# radix16digit = {STRINGTOBAG "0123456789abcedf", #?# times ten to the power = {STRINGTOBAG "\eE", #?# flipflop = {STRINGTOBAG (flip + flop), #?# plus i times = {STRINGTOBAG "`iI", #?# signspace = {STRINGTOBAG "+- ", #?# plusminus = {STRINGTOBAG "+-", #?# point = {STRINGTOBAG^STRING("."), #?# xylpkq = {STRINGTOBAG "xylpkq"; {MODE^FORMAT = {STRUCT({REF [] {COLLECTION #?# c); {MODE #?# {COLLECTION = {UNION({PICTURE, {COLLITEM); {MODE #?# {COLLITEM = {STRUCT({INSERTION i1, {PROC^INT rep, # replicator # {REF [] {COLLECTION p, {INSERTION i2); {MODE #?# {PICTURE = {UNION({SPICT, {DPICT, {CPICT, {FPICT, {GPICT, {VOIDPICT); {MODE #?# {SPICT = {STRUCT({UNION({INTPATTERN, {REALPATTERN, {BOOLPATTERN, {COMPLPATTERN, {STRINGPATTERN, {BITSPATTERN) p, {REF [] {SFRAME sframes); {MODE #?# {DPICT = {STRUCT({INT type, {REF [] {DFRAME frames); {MODE #?# {CPICT = {STRUCT({INSERTION i1, {INT type, {REF [] {INSERTION c, {INSERTION i2); {MODE #?# {FPICT = {STRUCT({INSERTION i1, {PROC^FORMAT pf, {INSERTION i2); {MODE #?# {GPICT = {STRUCT({INSERTION i1, {FLEX [1:0] {PROC^INT spec, {INSERTION i2); {MODE #?# {VOIDPICT = {INSERTION; {MODE #?# {INSERTION = {REF [] {DFRAME; {MODE #?# {DFRAME = {UNION({PROC^INT, {REF [] {CHAR, {CHAR); {MODE #?# {SFRAME = {UNION({INT, {REF [] {CHAR, {CHAR); {MODE #?# {INTPATTERN = {REF^STRUCT({INT width, sign); # 'width': The length of the string controlled by the integral pattern, including the possible sign-frame; 'sign' : The absolute value of 'sign' is the length of the string controlled by the sign mould of the pattern. If 'sign' < 0 (> 0), then the sign mould contains a descendent minus-symbol (plus-symbol). If 'sign' = 0, then the pattern contains no sign mould. Note that because of this way of coding there is no need for u- or v- frames, since the 'sign' field contains the necessary information. # {MODE #?# {REALPATTERN = {REF^STRUCT({INT b, s1, a, e, s2, point); # 'b' : The length of the string controlled by the first integral mould of the stagnant part of the pattern, including the possible sign-frame; 'a' : The length of the string controlled by the second integral mould of the stagnant part; 'e' : The length of the string controlled by the integral pattern of the exponent part, including the possible sign-frame; 's1' : The length of the string controlled by the sign mould of the stagnant part, coded in the same way as the 'sign' field of the integral pattern; 's2' : Idem for the sign mould of the exponent; 'point': 'point' = 1 if the pattern contains a point frame, and 0 otherwise. # {MODE #?# {COMPLPATTERN = {REF^STRUCT({REALPATTERN re, im); {MODE #?# {BOOLPATTERN = {VOID; {MODE #?# {STRINGPATTERN = {INT; # The length of the string controlled by the pattern. # {MODE #?# {BITSPATTERN = {REF^STRUCT({INT width, radix); # 'width': The length of the string controlled by the pattern; 'radix': The radix of the radix frame. # {MODE #?# {FORMATLIST = {STRUCT({INT count, # number of times current piece is to be repeated # cp, # pointer to current collection # {REF [] {COLLECTION p, # current collection list # {REF^FORMATLIST next # pointer to next piece # ); {PROC #?# get next picture = ({REF^FILE f, {REF^PICTURE picture) {VOID: {IF piece {OF f :=: {REF^REF^FORMATLIST({NIL) {THEN error(noformat); abort # no format provided # {ELSE^BOOL picture found:= {FALSE, {STATUS reading = status {OF cover {OF f; {IF cp {OF piece {OF f > {UPB p {OF piece {OF f {THEN update cp(f, {FALSE, {SKIP) {FI; # search for the next complete picture or collection list # {WHILE^NOT picture found {DO {IF cp {OF piece {OF f = 0 # format ended # {THEN^BOOL mended = (format mended {OF f)(f); ensure state(f, reading); {IF^NOT mended {THEN cp {OF piece {OF f:= count {OF piece {OF f:= 1 # re-iterate the format # {ELIF cp {OF piece {OF f = 0 # no appropriate mending # {THEN error(noformat); abort {FI {ELSE^REF^REF^FORMATLIST piece = piece {OF f; {CASE (p {OF piece)[cp {OF piece] {IN ({COLLITEM cl): {BEGIN {REF^FORMATLIST pl = piece; piece:= {NIL; # temporarily # [1 : {UPB i1 {OF cl] {SFRAME si; staticize frames(i1 {OF cl, si); {IF^REF^FORMATLIST(piece) {ISNT^NIL {THEN error(wrongformat); abort {FI; {INT count = rep {OF cl; {IF^REF^FORMATLIST(piece) {ISNT^NIL {THEN error(wrongformat); abort {FI; (reading {SAYS read mood | get insertion | put insertion) (f, si); {IF^REF^FORMATLIST(piece) {ISNT^NIL {THEN error(wrongformat); abort {FI; # make sure that no other format has been associated with the file # piece:= {REF^FORMATLIST(pseudo60) # a newly created name which is made to refer to the yield of an actual-formatlist-declarer and whose scope is equal to the scope of 'f' # := (count, 1, p {OF cl, pl); {IF count <= 0 # repeat zero times # {THEN picture found:= {TRUE; picture:= {VOIDPICT({HEAP [1:0] {DFRAME:= ()); cp {OF piece:= {UPB p {OF piece + 1 # This forces the yielding of a void picture. Subsequently, the second insertion of the collitem 'cl' will be performed. # {FI {END, ({PICTURE pict): (picture found:= {TRUE; picture:= pict; cp {OF piece +:= 1) {ESAC {FI {OD {FI; {PROC #?# update cp = ({REF^FILE f, {BOOL perform insertions, {STATUS reading) {VOID: {BEGIN^REF^REF^FORMATLIST piece = piece {OF f; {WHILE cp {OF piece > {UPB p {OF piece # piece ended # {DO {IF (count {OF piece -:= 1) > 0 {THEN cp {OF piece:= 1 # repeat this piece # {ELIF^REF^FORMATLIST next = next {OF piece; next :=: {REF^FORMATLIST({NIL) {THEN cp {OF piece:= 0 # format ended # {ELSE piece:= next; cp {OF piece +:= 1; {IF perform insertions {THEN^INSERTION extra = {CASE (p {OF piece)[cp {OF piece] {IN ({COLLITEM cl): i2 {OF cl, ({FPICT fp): i2 {OF fp {ESAC; [1 : {UPB extra] {SFRAME sinsert; staticize frames(extra, sinsert); (reading {SAYS read mood | get insertion | put insertion) (f, sinsert) {FI # handle second insertion of a collection list or format pattern # {FI {OD {END; {PROC #?# staticize frames = ({REF [] {DFRAME frames, {REF [] {SFRAME sframes) {VOID: {FOR i {TO^UPB frames {DO sframes[i]:= {CASE frames[i] {IN ({PROC^INT n): n, ({REF [] {CHAR s): s, ({CHAR a): a {ESAC {OD; {PROC #?# staticize picture = ({DPICT p) {SPICT: # 'staticize picture' turns a picture containing dynamic replicators into one containing only simple (integer) replicators. It also extracts information needed to build up the character string to be output from the frames of the picture. This information is collected in the 'p' field of the static picture that is delivered. # {BEGIN^HEAP [1 : {UPB frames {OF p] {SFRAME sf; staticize frames(frames {OF p, sf); [1 : {CASE type {OF p {IN 2, 6, 0, 12, 1 {OUT 1 {ESAC] {INT t, {INT count:= 0, rep:= 1, info:= 1, point:= 6, sign:= 2; {FOR i {TO^UPB t {DO t[i]:= 0 {OD; {FOR i {TO^UPB sf {DO {CASE sf[i] {IN ({INT n): rep:= 0 {MAX n, ({CHAR a): ( {IF a = "a" {OR a = "d" {OR a = "z" {THEN count +:= rep {ELIF a = "+" {THEN count +:= 1; t[sign]:= count {ELIF a = "-" {THEN count +:= 1; t[sign]:= -count {ELIF a = "." {THEN t[info]:= count; count:= 0; info +:= 2; t[point]:= 1 {ELIF a = "e" {THEN t[info]:= count; count:= 0; info:= point - 2; sign:= point - 1 {ELIF a = "i" {THEN t[info]:= count; count:= 0; info:= 7; sign:= 8; point:= 12 {ELSE^SKIP {FI; rep:= 1) {OUT rep:= 1 {ESAC {OD; ({UPB t > 0 | t[info]:= count); ({CASE type {OF p {IN # integral # {HEAP^STRUCT({INT width, sign):= (t[1], t[2]), # real # {HEAP^STRUCT({INT b, s1, a, e, s2, point):= (t[1], t[2], t[3], t[4], t[5], t[6]), # boolean # {EMPTY, # complex # {HEAP^STRUCT({REALPATTERN re, im):= (({HEAP^STRUCT({INT b, s1, a, e, s2, point):= (t[1], t[2], t[3], t[4], t[5], t[6]), {HEAP^STRUCT({INT b, s1, a, e, s2, point):= (t[7], t[8], t[9], t[10], t[11], t[12]))), # string # t[1] {OUT # bits # {HEAP^STRUCT({INT width, radix):= (t[1], type {OF p - 4) {ESAC, sf) {END; {PROC #?# put insertion = ({REF^FILE f, {REF [] {SFRAME sf) {VOID: {BEGIN^INT rep:= 1; {IF^NOT (status {OF cover {OF f {SAYS put char status) {THEN ensure state(f, put char status) {FI; {FOR sfp {FROM^LWB sf {TO^UPB sf {DO {CASE sf[sfp] {IN ({INT count): rep:= count, ({REF [] {CHAR s): (put insert string(f, rep, s); rep:= 1), ({CHAR a): (alignment(f, rep, a); rep:= 1) {ESAC {OD {END; {PROC #?# put insert string = ({REF^FILE f, {INT rep, {REF [] {CHAR s) {VOID: # mood ok # {TO rep {DO {FOR i {TO^UPB s {DO {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN put char(f, s[i]) {ELSE error(nocharpos); abort {FI {OD {OD; {PROC #?# get insertion = ({REF^FILE f, {REF [] {SFRAME sf) {VOID: {BEGIN^INT rep:= 1; {IF^NOT (status {OF cover {OF f {SAYS get char status) {THEN ensure state(f, get char status) {FI; {FOR sfp {FROM^LWB sf {TO^UPB sf {DO {CASE sf[sfp] {IN ({INT count): rep:= count, ({REF [] {CHAR s): (get insert string(f, rep, s); rep:= 1), ({CHAR a): (alignment(f, rep, a); rep:= 1) {ESAC {OD {END; {PROC #?# get insert string = ({REF^FILE f, {INT rep, {REF [] {CHAR s) {VOID: # mood ok # {BEGIN^CHAR c, si; {TO rep {DO {FOR i {TO^UPB s {DO {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN get char(f, c) {ELSE error(nocharpos); abort {FI; {IF c /= (si:= s[i]) {THEN^BOOL mended = (char error mended {OF f)(f, si); ensure state(f, get char status); ({NOT mended | error(wrongchar); abort) {FI {OD {OD {END; {PROC #?# alignment = ({REF^FILE f, {INT r, {CHAR a) {VOID: {IF a = "x" {THEN^TO r {DO space(f) {OD {ELIF a = "y" {THEN^TO r {DO backspace(f) {OD {ELIF a = "l" {THEN^TO r {DO newline(f) {OD {ELIF a = "p" {THEN^TO r {DO newpage(f) {OD {ELIF a = "k" {THEN set char number(f, r) {ELIF a = "q" {THEN {IF status {OF cover {OF f {SAYS read mood {THEN get insert string {ELSE put insert string {FI (f, r, {LOC [1 : 1] {CHAR:= blank) {FI; {PROC #?# do fpict = ({REF^FILE f, {FPICT fpict) {VOID: {BEGIN [1 : {UPB i1 {OF fpict] {SFRAME si; {REF^FORMATLIST pl = piece {OF f; {REF^REF^FORMATLIST(piece {OF f):= {NIL; # temporarily # {STATUS reading = status {OF cover {OF f; staticize frames(i1 {OF fpict, si); {IF^REF^FORMATLIST(piece {OF f) {ISNT^NIL {THEN error(wrongformat); abort {FI; {FORMAT pf = pf {OF fpict; {IF^REF^FORMATLIST(piece {OF f) {ISNT^NIL {THEN error(wrongformat); abort {FI; (reading {SAYS read mood | get insertion | put insertion)(f, si); {IF^REF^FORMATLIST(piece {OF f) {ISNT^NIL {THEN error(wrongformat); abort {FI; # make sure that no other format has been associated with the file # cp {OF pl -:= 1; # to ensure that the second insertion will eventually be handled # {REF^REF^FORMATLIST(piece {OF f):= {REF^FORMATLIST(pseudo61) # a newly created name which is made to refer to the yield of an actual-formatlist-declarer and whose scope is equal to the scope of 'f' # := (1, 1, c {OF pf, pl) {END; {PROC #?# associate format = ({REF^FILE f, {FORMAT format) {VOID: piece {OF f:= {REF^REF^FORMATLIST(pseudo62) # a newly created name which is made to refer to the yield of an actual- reference-to-formatlist-declarer and whose scope is equal to the scope of 'f' # := {REF^FORMATLIST(pseudo63) # a newly created name which is made to refer to the yield of an actual- formatlist-declarer and whose scope is equal to the scope of 'f' # := (1, 1, c {OF format, {NIL); {PROC #?# edit string = ({REF^FILE f, {REF [] {SFRAME sf, {REF^INT sfp, {REF [] {CHAR s, {BOOL end) {VOID: # All characters in 's' are mapped one by one against the frames in 'sf' from the position indicated by 'sfp' onwards. At the end, 'sfp' will point just beyond the last frame in 'sf' that has been used. If 'end' is true, the possible trailing frames in 'sf' (which in that case correspond to some final insertion) are handled also. # {BEGIN^INT rep:= 1, j:= {LWB s - 1, {CHAR k, {BOOL supp:= {FALSE, zs:= {TRUE; {PROC copy = ({CHAR c) {VOID: {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN put char(f, c) {ELSE error(nocharpos); abort {FI; {WHILE j < {UPB s {OR (end {AND sfp <= {UPB sf) {DO {CASE sf[sfp] {IN ({INT count): rep:= count, ({REF [] {CHAR s): (put insert string(f, rep, s); rep:= 1), ({CHAR a): {IF a = "s" {THEN supp:= {TRUE {ELSE {IF a = "d" {THEN zs:= {TRUE; {IF supp {THEN j +:= rep {ELSE {TO rep {DO k:= s[j +:= 1]; copy((k = " " | "0" | k)) {OD {FI {ELIF a = "z" {THEN {TO rep {DO k:= s[j +:= 1]; (zs | (k = "0" | k:= " " |: k /= " " | zs:= {FALSE)); ({NOT supp | copy(k)) {OD {ELIF a = "a" {THEN {IF supp {THEN j +:= rep {ELSE^TO rep {DO copy(s[j +:= 1]) {OD {FI {ELIF a = "+" {OR a = "-" {THEN k:= s[j +:= 1]; (zs | (k = "0" | k:= " " |: k /= "+" {AND k /= "-" {AND k /= " " | zs:= {FALSE)); copy(k) {ELIF a = "." {THEN ({NOT supp | copy(".")); j +:= 1 {ELIF a = "e" {OR a = "i" {THEN ({NOT supp | copy(a)); zs:= {TRUE {ELIF a = "b" {THEN copy(s[j +:= 1]) {ELIF a = "r" {THEN^SKIP {ELSE alignment(f, rep, a) {FI; supp:= {FALSE; rep:= 1 {FI {ESAC; sfp +:= 1 {OD {END; {PROC putf = ({REF^FILE f, [] {UNION({OUTTYPE, {FORMAT) x) {VOID: {BEGIN {IF^NOT (status {OF cover {OF f {SAYS put char status) {THEN ensure state(f, put char status) {FI; {FOR k {TO^UPB x {DO {CASE x[k] {IN ({FORMAT format): associate format(f, format), ({OUTTYPE ot): {BEGIN^INT j:= 0, {PICTURE picture, [] {SIMPLOUT y = {STRAIGHTOUT ot; {WHILE (j +:= 1) <= {UPB y {DO^BOOL incomp:= {FALSE; get next picture(f, picture); # mood ok # {INT n = {CASE picture {IN ({DPICT dp): (picture:= staticize picture(dp); # now the mode of 'picture' is '{SPICT' # ensure state(f, put char status); 0), ({CPICT cp): {UPB i2 {OF cp, ({GPICT gp): {UPB i2 {OF gp, ({VOIDPICT vp): {UPB vp {OUT 0 {ESAC; {REF [] {SFRAME sinsert:= {LOC [1 : n] {SFRAME; # space for the final insertion of a 'choice-', 'general-' or 'void-pattern' # {CASE picture {IN ({SPICT sp): {BEGIN^INT sfp:= 1, {REF [] {SFRAME sf = sframes {OF sp; {PROC convert l real = ({REALPATTERN rp, {REF [] {CHAR s, {REF^INT first, last, {UNION(#<##L# {REAL#>#) x) {BOOL: # 'x' is converted into 's' from position 'first' up to 'last', using the information from 'rp' # {IF^INT sign1 = {ABS s1 {OF rp; {INT before = b {OF rp - {SIGN sign1; e {OF rp > 0 {THEN^INT exp:= before, rplace; {BOOL neg1 = subfixed(x, a {OF rp, exp, s, {TRUE); last:= a {OF rp + before + point {OF rp; first:= {IF power10(s, rplace, last) {THEN exp +:= 1; s[before]:= "."; s[before+1]:= (before = 0 | rplace:= 1; "0" | "9"); last -:= 1; 0 # xxx9.xxx => xxx.9xxx, .9xxx => 0.xxx # {ELSE 1 {FI; round(s, rplace, last); {IF sign1 /= 0 {THEN s[first -:= 1]:= (neg1 | "-" |: s1 {OF rp > 0 | "+" | " ") {FI; # now s[first:last] contains the stagnant part of x # exp -:= before; # note that "e" is not explicitly stored in 's', so the exponent starts at position 'last+1' in 's' # {INT f:= last + 1; {BOOL neg2 = subwhole(exp, f, last + e {OF rp, s); {INT sign2 = {ABS s2 {OF rp; {IF last + {SIGN sign2 >= f {OR (sign2 = 0 {AND neg2) {OR (sign1 = 0 {AND neg1) {THEN^FALSE {ELSE (sign2 /= 0 | s[(sign2 + last) {MIN (f - 1)]:= (neg2 | "-" |: s2 {OF rp > 0 | "+" | " ")); last +:= e {OF rp; {TRUE {FI {ELSE # e {OF rp = 0 # {INT bb, rplace; {BOOL neg1 = subfixed(x, a {OF rp, bb, s, {FALSE); last:= bb + a {OF rp + point {OF rp - 1; first:= (power10(s, rplace, last) | bb +:= 1; 0 | 1); round(s, rplace, last); {IF^INT p = bb - 1 - b {OF rp; # '-p' is equal to the space left unfilled # p + {SIGN sign1 > 0 {OR (sign1 = 0 {AND neg1) {THEN^FALSE {ELSE (sign1 /= 0 | s[(sign1 + p) {MIN (first - 1)]:= (neg1 | "-" |: s1 {OF rp > 0 | "+" | " ")); first:= p + 1; {TRUE {FI {FI; {PROC edit l real = ({UNION(#<##L# {REAL#>#) x, {REALPATTERN rp) {VOID: {IF^INT u, v; {IF e {OF rp > 0 {THEN u:= -1; v:= b {OF rp + a {OF rp + 2 + {EXPWIDTH x {MAX e {OF rp {ELSE^INT b = log10(x); u:= 0 {MIN (b - b {OF rp) - 1; v:= b + a {OF rp + 2 {FI; # guess lower and upper bound for 's' # [u : v] {CHAR s, {INT first, last; convert l real(rp, s, first, last, x) {THEN edit string(f, sf, sfp, s[first : last], {TRUE) {ELSE incomp:= {TRUE {FI; {PROC edit l compl = ({UNION(#<##L# {COMPL#>#) z, {COMPLPATTERN cp) {VOID: {IF^UNION(#<##L# {REAL#>#) re z = {CASE z {IN #<#(#L# {COMPL zz): re {OF zz#># {ESAC, im z = {CASE z {IN #<#(#L# {COMPL zz): im {OF zz#># {ESAC, {INT u1, v1, u2, v2; {IF e {OF re {OF cp > 0 {THEN u1:= -1; v1:= b {OF re {OF cp + a {OF re {OF cp + 2 + {EXPWIDTH re z {MAX e {OF re {OF cp {ELSE^INT b = log10(re z); u1:= 0 {MIN (b - b {OF re {OF cp) - 1; v1:= b + a {OF re {OF cp + 2 {FI; {IF e {OF im {OF cp > 0 {THEN u2:= -1; v2:= b {OF im {OF cp + a {OF im {OF cp + 2 + {EXPWIDTH im z {MAX e {OF im {OF cp {ELSE^INT b = log10(im z); u2:= 0 {MIN (b - b {OF im {OF cp) - 1; v2:= b + a {OF im {OF cp + 2 {FI; # guess lower and upper bound for 's re' and 's im' # [u1 : v1] {CHAR s re, [u2 : v2] {CHAR s im, {INT f re, l re, f im, l im; convert l real(re {OF cp, s re, f re, l re, re z) {AND convert l real(im {OF cp, s im, f im, l im, im z) {THEN edit string(f, sf, sfp, s re[f re : l re], {FALSE); edit string(f, sf, sfp, s im[f im : l im], {TRUE) {ELSE incomp:= {TRUE {FI; {CASE p {OF sp {IN ({INTPATTERN ip): (y[j] | ({UNION(#<##L# {INT#>#) i): {IF^INT upbs = {INTWIDTH i {MAX width {OF ip; [0 : upbs] {CHAR s, {INT first:= 0; {BOOL neg = subwhole(i, first, upbs, s); # 'first' points to the first digit of 'i' in 's' # {INT p = upbs - width {OF ip, # 'p+1' is the first usable position in 's' # abssign = {ABS sign {OF ip; p + {SIGN abssign >= first {OR (abssign = 0 {AND neg) {THEN incomp:= {TRUE {ELSE (abssign /= 0 | s[(abssign + p) {MIN (first - 1)]:= (neg | "-" |: sign {OF ip > 0 | "+" | " ")); # place sign # edit string(f, sf, sfp, s[p + 1 : ], {TRUE) {FI | incomp:= {TRUE), ({REALPATTERN rp): (y[j] | #<#(#L# {REAL r): edit l real(r, rp)#>#, #<#(#L# {INT i): edit l real(#L# {REAL(i), rp)#># # knowing the internal representation of numbers, this case clause can presumably be optimized # | incomp:= {TRUE), ({BOOLPATTERN bp): (y[j] | ({BOOL b): edit string(f, sf, sfp, {LOC [1:1] {CHAR:= (b | flip | flop), {TRUE) | incomp:= {TRUE), ({COMPLPATTERN cp): (y[j] | #<#(#L# {COMPL z): edit l compl(z, cp)#>#, #<#(#L# {REAL r): edit l compl(#L# {COMPL(r), cp)#>#, #<#(#L# {INT i): edit l compl(#L# {COMPL(i), cp)#># # knowing the internal representation of numbers, this case clause can presumably be optimized # | incomp:= {TRUE), ({STRINGPATTERN stp): (y[j] | ({CHAR c): {IF stp = 1 {THEN edit string(f, sf, sfp, {LOC [1:1] {CHAR:= c, {TRUE) {ELSE incomp:= {TRUE {FI, ([] {CHAR t): {IF stp = ({UPB t - {LWB t + 1) {MAX 0 # mind superflat rows # {THEN edit string(f, sf, sfp, {LOC [1:stp] {CHAR:= t, {TRUE) {ELSE incomp:= {TRUE {FI | incomp:= {TRUE), ({BITSPATTERN bp): (y[j] | #<#(#L# {BITS lb): {IF^INT upbs = xlx bits width {MAX width {OF bp; [1 : upbs] {CHAR s, #L# {INT n:= {ABS lb, {INT first:= upbs; {WHILE s[first]:= dig char(#S#(n {MOD #K# radix {OF bp)); n {OVERAB #K# radix {OF bp; n /= #L# 0 {DO first -:= 1 {OD; {INT p = upbs - width {OF bp + 1; # 'p' is the first usable position in 's' # p > first {THEN incomp:= {TRUE {ELSE {WHILE p < first {DO s[first -:= 1]:= " " {OD; edit string(f, sf, sfp, s[p : ], {TRUE) {FI#># | incomp:= {TRUE) {ESAC; {IF incomp {THEN sfp:= {UPB sf; {WHILE {CASE sf[sfp] {IN ({CHAR a): char in bag(a, xylpkq) {OUT^TRUE {ESAC {DO sfp -:= 1 {OD; sinsert:= sf[sfp + 1 : ] # the last insertion of 'sf' is searched for; this insertion will be performed after the 'value error mended' routine has been called and (possibly) some default action has been taken # {FI {END, ({CPICT choice): {BEGIN [1 : {UPB i1 {OF choice] {SFRAME si; staticize frames(i1 {OF choice, si); put insertion(f, si); {INT l = {CASE type {OF choice {IN # boolean # (y[j] | ({BOOL b): (b | 1 | 2) | incomp:= {TRUE; {SKIP), # integral # (y[j] | ({INT i): i | incomp:= {TRUE; {SKIP) {ESAC; {IF^NOT (incomp:= incomp {OR l <= 0 {OR l > {UPB c {OF choice) {THEN^INSERTION cl = (c {OF choice)[l]; [1 : {UPB cl] {SFRAME ci; staticize frames(cl, ci); put insertion(f, ci) {FI; staticize frames(i2 {OF choice, sinsert) {END, ({FPICT fpict): {BEGIN j -:= 1; # since 'y[j]' has not been output yet # do fpict(f, fpict) {END, ({GPICT gpict): {BEGIN [1 : {UPB i1 {OF gpict] {SFRAME si; staticize frames(i1 {OF gpict, si); staticize frames(i2 {OF gpict, sinsert); {INT n = {UPB spec {OF gpict; [1 : n] {INT s; {FOR i {TO n {DO s[i]:= (spec {OF gpict)[i] {OD; put insertion(f, si); {IF n = 0 {THEN put(f, y[j]) {ELSE {NUMBER yj = (y[j] | #<#(#L# {INT i): i#>#, #<#(#L# {REAL r): r#># | incomp:= {TRUE; {SKIP); {IF^NOT incomp {THEN {CASE n {IN put(f, whole(yj, s[1])), put(f, fixed(yj, s[1], s[2])), put(f, float(yj, s[1], s[2], s[3])) # For optimization purposes, one might want to generate different code here. # {ESAC {FI {FI {END, ({VOIDPICT v): {BEGIN j -:= 1; # since 'y[j]' has not been output yet # staticize frames(v, sinsert) {END {ESAC; {IF incomp {THEN ensure state(f, put char status); {BOOL mended = (value error mended {OF f)(f); ensure state(f, put char status); ({NOT mended | put(f, y[j]); error(wrongval); abort) {FI; {IF^UPB sinsert > {LWB sinsert {THEN put insertion(f, sinsert) {FI; # put the final insertion of the picture at hand # {IF cp {OF piece {OF f > {UPB p {OF piece {OF f # piece ended # {THEN update cp(f, {TRUE, put char status) {FI # search for the next complete picture or collection list, in the meantime outputting final insertions # {OD {END {ESAC {OD {END; {PROC #?# indit string = ({REF^FILE f, {REF [] {SFRAME sf, {REF^INT sfp, {REF [] {CHAR s, {INT sign, radix, {BOOL end) {VOID: # The frames in 'sf' from the position indicated by 'sfp' onwards are used to indit 'index' characters, which are placed in 's' from position 1 onwards. At the end, 'sfp' will point just beyond the last frame in 'sf' that is used. If 'end' is true, the possible trailing frames in 'sf' are handled also. # {BEGIN {CHARBAG digits = ( radix = 10 | radix10digit |: radix = 2 | radix 2digit |: radix = 4 | radix 4digit |: radix = 8 | radix 8digit | radix16digit); {CHARBAG digits and space = digits {MERGEWITH^STRINGTOBAG^STRING(" "), digits and signspace = digits {MERGEWITH signspace; {PROC expect char = ({CHARBAG s, {CHAR c) {CHAR: # expects a character contained in 's'; if the character read is not in 's', then the event routine corresponding to the 'on char error' event is called, with the suggestion 'c' # {IF^CHAR k; {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN get char(f, k) {ELSE error(nocharpos); abort {FI; char in bag(k, s) {THEN k {ELSE k:= c; {BOOL mended = (char error mended {OF f)(f, k); ensure state(f, get char status); {IF (mended | char in bag(k, s) | {FALSE) {THEN k {ELSE error(wrongchar); c {FI {FI; {INT index:= {ABS sign, rep:= 1, {BOOL sign found:= {FALSE, first space:= {FALSE, supp:= {FALSE; {CHARBAG allowed:= {CASE sign + 2 {IN # "-"-frame # (first space:= {TRUE; signspace), # no frame # (sign found:= {TRUE; digits and space), # "+"-frame # signspace {ESAC; {WHILE index < {UPB s {OR (end {AND sfp <= {UPB sf) {DO {CASE sf[sfp] {IN ({INT count): rep:= count, ({REF [] {CHAR s): (get insert string(f, rep, s); rep:= 1), ({CHAR a): {IF a = "s" {THEN supp:= {TRUE {ELSE {IF a = "d" {THEN {TO rep {DO s[index +:= 1]:= (supp | "0" | expect char(digits, "0")) {OD; allowed:= digits and space {ELIF a = "z" {OR a = "+" {OR a = "-" {THEN {TO rep {DO {IF supp {THEN s[index +:= 1]:= "0" {ELIF sign found {THEN s[index +:= 1]:= ({CHAR c = expect char(allowed, "0"); (c /= " " | allowed:= digits; c | "0")) {ELSE^CHAR c:= expect char((a = "+" | plusminus | allowed), "+"); {IF c = " " {AND a = "z" {THEN (first space | allowed:= digits and signspace; first space:= {FALSE); c:= "0" {ELSE sign found:= {TRUE; allowed:= digits; (c = " " | c:= "+") {FI; (c = "+" {OR c = "-" | s[1]:= c | s[index +:= 1]:= c) {FI {OD {ELIF a = "." {THEN ({NOT supp | expect char(point, ".")) {ELIF a = "e" {THEN ({NOT supp | expect char(times ten to the power, "e")) {ELIF a = "i" {THEN ({NOT supp | expect char(plus i times, "i")) {ELIF a = "r" {THEN^SKIP {ELIF a = "b" {THEN s[index +:= 1]:= expect char(flipflop, flop) {ELIF a = "a" {THEN {TO rep {DO s[index +:= 1]:= {IF supp {THEN " " {ELSE^CHAR c; {IF {IF status {OF cover {OF f {SAYS line ok {THEN^TRUE {ELSE check pos(f) {FI {THEN get char(f, c) {ELSE error(nocharpos); abort {FI; c {FI {OD {ELSE alignment(f, rep, a) {FI; rep:= 1; supp:= {FALSE {FI {ESAC; sfp +:= 1 {OD {END; {PROC getf = ({REF^FILE f, [] {UNION({INTYPE, {FORMAT) x) {VOID: {BEGIN {IF^NOT (status {OF cover {OF f {SAYS get char status) {THEN ensure state(f, get char status) {FI; {FOR k {TO^UPB x {DO {CASE x[k] {IN ({FORMAT format): associate format(f, format), ({INTYPE it): {BEGIN^INT j:= 0, {PICTURE picture, [] {SIMPLIN y = {STRAIGHTIN it; {WHILE (j +:= 1) <= {UPB y {DO^BOOL incomp:= {FALSE; get next picture(f, picture); {INT n = {CASE picture {IN ({DPICT dp): (picture:= staticize picture(dp); # now the mode of 'picture' is '{SPICT' # ensure state(f, get char status); 0), ({CPICT cp): {UPB i2 {OF cp, ({GPICT gp): {UPB i2 {OF gp, ({VOIDPICT vp): {UPB vp {OUT 0 {ESAC; [1 : n] {SFRAME sinsert; # since the last insertion of a simple picture is always handled by 'indit string', no special arrangements to recover this final insertion need be made here (as had to be done in 'putf') # {CASE picture {IN ({SPICT sp): {BEGIN^INT sfp:= 1, {REF [] {SFRAME sf = sframes {OF sp; {PROC convert l real = ({REALPATTERN rp, {UNION(#<#{REF #L# {REAL#>#) rr, {BOOL end) {BOOL: {BEGIN^INT upbs = a {OF rp + b {OF rp, exp width = e {OF rp; [1 : upbs] {CHAR s; indit string(f, sf, sfp, s, {SIGN s1 {OF rp, 10, exp width = 0 {AND end); {BOOL ok:= {TRUE, {INT first:= (s1 {OF rp = 0 | 1 | 2); # 's' contains the digits from the stagnant part; 'first' points to the first digit # {WHILE first < upbs {AND s[first] = "0" {DO first +:= 1 {OD; # skip leading zeroes; 'first' now points to the first significant digit # {INT last = (first + {RREALWIDTH rr) {MIN upbs; {INT exp:= b {OF rp - last; # distance from the (implicit) decimal point to the last significant digit # {IF exp width > 0 {THEN [1 : exp width] {CHAR s; indit string(f, sf, sfp, s, {SIGN s2 {OF rp, 10, end); # 's' contains the exponent, including the sign, if any # {INT e:= 0; {FOR i {FROM (s2 {OF rp = 0 | 1 | 2) {TO exp width {WHILE ok {DO ok:= e {ADD char dig(s[i]) {OD; {IF ok:= ok {AND^ABS exp <= max int - e {THEN exp +:= (s[1] = "-" | -e | e) {FI # test for integer overflow, and determine exponent # {FI; {IF^NOT ok {THEN^FALSE {ELSE string to l real(s[first:last], exp, s[1] = "-", rr) {FI {END; {CASE p {OF sp {IN ({INTPATTERN ip): (y[j] | #<#({REF #L# {INT ii): {BEGIN [1 : width {OF ip] {CHAR s; indit string(f, sf, sfp, s, sign {OF ip, 10, {TRUE); # 's' contains all digits, and the sign, if any # {BOOL ok:= {TRUE, #L# {INT j:= #L# 0; {FOR i {FROM (sign {OF ip = 0 | 1 | 2) {TO width {OF ip {WHILE ok {DO ok:= j {ADD char dig(s[i]) {OD; (ok | ii:= (s[1] = "-" | -j | j)); incomp:= {NOT ok {END#># | incomp:= {TRUE), ({REALPATTERN rp): (y[j] | ({UNION(#<#{REF #L# {REAL#>#) rr): incomp:= {NOT convert l real(rp, rr, {TRUE) | incomp:= {TRUE), ({BOOLPATTERN bp): (y[j] | ({REF^BOOL bb): {BEGIN [1 : 1] {CHAR s; indit string(f, sf, sfp, s, 0, 0, {TRUE); bb:= s[1] = flip {END | incomp:= {TRUE), ({COMPLPATTERN cp): (y[j] | #<#({REF #L# {COMPL zz): incomp:= {NOT {IF convert l real(re {OF cp, re {OF zz, {FALSE) {THEN convert l real(im {OF cp, im {OF zz, {TRUE) {ELSE^FALSE {FI#># | incomp:= {TRUE), ({STRINGPATTERN stp): (y[j] | ({REF^CHAR cc): {IF stp = 1 {THEN indit string(f, sf, sfp, {REF [] {CHAR(cc), 0, 0, {TRUE) {ELSE incomp:= {TRUE {FI, ({REF [] {CHAR ss): {IF stp = ({UPB ss - {LWB ss + 1) {MAX 0 {THEN indit string(f, sf, sfp, ss[@1], 0, 0, {TRUE) {ELSE incomp:= {TRUE {FI, ({REF^STRING ss): {BEGIN [1 : stp] {CHAR s; indit string(f, sf, sfp, s, 0, 0, {TRUE); ss:= s {END | incomp:= {TRUE), ({BITSPATTERN bp): (y[j] | #<#({REF #L# {BITS lb): {BEGIN [1 : width {OF bp] {CHAR s, {INT radix = radix {OF bp; indit string(f, sf, sfp, s, 0, radix, {TRUE); {INT r = (radix = 2 | 1 |: radix = 4 | 2 |: radix = 8 | 3 | 4), {INT w:= width {OF bp, n:= 0, d, [1 : xlx bits width] {BOOL b; {FOR i {FROM xlx bits width {BY -1 {TO 1 {DO {IF n = 0 {THEN d:= (w > 0 | char dig(s[w]) | 0); w -:= 1; n:= r {FI; b[i]:= {ODD d; d:= d {OVER 2; n -:= 1 {OD; # convert radix integer to [] {BOOL # lb:= xlx bits pack(b) {END#># | incomp:= {TRUE) {ESAC {END, ({CPICT choice): {BEGIN [1 : {UPB i1 {OF choice] {SFRAME si; staticize frames(i1 {OF choice, si); get insertion(f, si); {INT c = c {OF cpos {OF cover {OF f, {CHAR kk, {INT k:= 0, {BOOL found:= {FALSE; {IF^NOT (possibles {OF cover {OF f {SAYS backspace poss) {THEN error(nobackspace); abort {FI; {WHILE k < {UPB c {OF choice {AND^NOT found {DO^INSERTION ck = (c {OF choice)[k +:= 1]; [1 : {UPB ck] {SFRAME si; staticize frames(ck, si); ensure state(f, get char status); {BOOL bool:= {TRUE, {INT rep:= 1; {FOR i {TO^UPB si {WHILE bool {DO {CASE si[i] {IN ({INT count): rep:= count, ({REF [] {CHAR ss): ({FOR j {TO rep {WHILE bool {DO {FOR l {TO^UPB ss {WHILE bool:= bool {AND status {OF cover {OF f {SAYS line ok {DO get char(f, kk); bool:= kk = ss[l] {OD {OD; rep:= 1) {ESAC {OD; # try to read 'si' # ({NOT (found:= bool) | set char number(f, c)) {OD; # try successive insertions until 'si' is found # {IF^NOT found {THEN incomp:= {TRUE {ELSE {CASE type {OF choice {IN # boolean # (y[j] | ({REF^BOOL b): b:= k = 1 | incomp:= {TRUE), # integral # (y[j] | ({REF^INT i): i:= k | incomp:= {TRUE) {ESAC {FI; staticize frames(i2 {OF choice, sinsert) {END, ({FPICT fpict): (j -:= 1; do fpict(f, fpict)), ({GPICT gpict): {BEGIN [1 : {UPB i1 {OF gpict] {SFRAME si; staticize frames(i1 {OF gpict, si); staticize frames(i2 {OF gpict, sinsert); get insertion(f, si); get(f, y[j]); incomp:= {UPB spec {OF gpict > 0 {END, ({VOIDPICT v): (j -:= 1; staticize frames(v, sinsert)) {ESAC; {IF incomp {THEN ensure state(f, get char status); {BOOL mended = (value error mended {OF f)(f); ensure state(f, get char status); ({NOT mended | error(wrongval); abort) {FI; {IF^UPB sinsert > {LWB sinsert {THEN get insertion(f, sinsert) {FI; # get the final insertion of a 'choice-', 'general-' or 'void-pattern' # {IF cp {OF piece {OF f > {UPB p {OF piece {OF f {THEN update cp(f, {TRUE, get char status) {FI # search for the next complete picture or collection list, in the meantime inputting final insertions # {OD {END {ESAC {OD {END; {MODE #?# {BINCHAR = {PSEUDO64 # The elementary mode of binary transput; each value is transput via some 'row of {BINCHAR', the length of the row being determined by the book to which the transput takes place, the mode of the value to be transput (and its length in the case of a multiple value). #; {PROC #?# to bin = ({REF^FILE f, {OUTTYPE x) [] {BINCHAR: {BINCHAR(pseudo65) # The lower bound of the resulting multiple value is 1, the upper bound depends on 'f' and on the mode and the value of 'x'; furthermore, x = from bin(f, x, to bin(f, x)). #; {PROC #?# from bin = ({REF^FILE f, {OUTTYPE y, [] {BINCHAR c) {OUTTYPE: {OUTTYPE(pseudo66) # A value, if one exists, of the mode of the value yielded by 'y', such that c = to bin(f, from bin(f, y, c)). If such a value does not exist, an error message 'wrongbin' is given and the program is aborted. #; {PROC #?# bin length = ({REF^FILE f, {INTYPE y) {INT: {INT(pseudo67) # The upper bound of the multiple value which is needed to input a value into 'y'. #; {PROC put bin = ({REF^FILE f, [] {OUTTYPE ot) {VOID: {BEGIN {IF^NOT (status {OF cover {OF f {SAYS put bin status) {THEN ensure state(f, put bin status) {FI; {FOR k {TO^UPB ot {DO [] {BINCHAR bin = to bin(f, ot[k]); {FOR i {TO^UPB bin {DO {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; (write bin char {OF f)(f, bin[i]); {REF^COVER cover = cover {OF f; {IF c {OF cpos {OF cover > char bound {OF cover {THEN status {OF cover {ANDAB line end {FI {OD {OD {END; {PROC get bin = ({REF^FILE f, [] {INTYPE it) {VOID: {BEGIN {IF^NOT (status {OF cover {OF f {SAYS get bin status) {THEN ensure state(f, get bin status) {FI; {FOR k {TO^UPB it {DO [1 : bin length(f, it[k])] {BINCHAR bin; {FOR i {TO^UPB bin {DO {IF^NOT (status {OF cover {OF f {SAYS line ok) {THEN next pos(f) {FI; (read bin char {OF f)(f, bin[i]); {REF^COVER cover = cover {OF f; {REF^STATUS status = status {OF cover; {IF c {OF cpos {OF cover = c of lpos {OF cover {THEN {IF status {SUGGESTS lfe in current line {THEN status {ANDAB logical file ended {ELSE status {ANDAB line end {FI {FI {OD; {VOID(pseudo68) # the name yielded by 'it[k]' := from bin(f, it[k], bin) # {OD {END; {FILE standin, standout, standback; {IF^STRING s = {STRING(pseudo69) # the identification string of the standard input file #; open(standin, s, stand in channel) = 0 {THEN^SKIP {ELIF {BOOL(pseudo70) # construct an empty book with identification string 's' #; {INT er = open(standin, s, stand in channel); er /= 0 {THEN error(er); abort {FI; {IF^STRING s = {STRING(pseudo71) # the identification string of the standard output file #; open(standout, s, stand out channel) = 0 {THEN^SKIP {ELIF^POS default = default size(stand out channel); {INT er = establish(standout, s, stand out channel, p {OF default, l {OF default, c {OF default); er /= 0 {THEN error(er); abort {FI; {IF^STRING s = {STRING(pseudo72) # the identification string of the standard standback file #; open(standback, s, stand back channel) = 0 {THEN^SKIP {ELIF^POS default = default size(stand back channel); {INT er = establish(standback, s, stand back channel, p {OF default, l {OF default, c {OF default); er /= 0 {THEN error(er); abort {FI; {PROC #?# error = ({INT er){VOID: {VOID(pseudo73) # some appropriate action #; #?# abort: {VOID(pseudo74) # some appropriate action # {END ######