%external %routine %spec writeprofile(%string(11) key, %name info, %integer %name version, flag) %external %routine %spec readprofile(%string(11) key, %name info, %integer %name version, flag) %system %routine %spec setpar(%string(255) s) %system %string(255) %fn %spec spar(%integer i) %system %integer %fn %spec parmap %system %integer %fn %spec pstoi(%string(255) s) %system %string(255) %fn %spec substring(%string %name s, %integer i, j) %external %routine %spec prompt(%string(255) s) %external %integer %fn %spec uinfi(%integer i) %external %string(255) %fn %spec ucstring(%string(255) s) %system %string %fn %spec itos(%integer i) %const %integer secsin24hrs = 86400; ! SECS IN DAY %const %integer days70 = 25567; ! DAYS FROM JAN1 1900 TO JAN1 1970 %const %long %integer secs70 = x'0000000083AA7E80'; ! SECS DITTO %const %string(1) snl = " " %const %integer maxmemos=10 %record %format proff(%integer %array after(1:maxmemos), %string(255) %array text(1:maxmemos)) %own %integer prof read=0 %own %record(proff) profile value %const %string(11) profile key="BISH#MEMOS1" %const %integer profile vsn=1 %own %integer vsn,flag %integer %fn start of(%string(255) whole string, first part, %string(*) %name rest) %result = 0 %unless %c 0 < length(first part) <= length(whole string) %and %c first part = substring(whole string, 1, length(first part)) whole string -> (first part).rest %result = 1 %end; !OF START OF %routine kdate(%integer %name d, m, y, %integer k) !! K IS DAYS SINCE 1ST JAN 1900 !! RETURNS D, M, Y 2 DIGIT Y ONLY ! %integer W ! K=K+693902 ! DAYS SINCE CEASARS BDAY ! W=4*K-1 ! Y=W//146097 ! K=W-146097*Y ! D=K//4 ! K=(4*D+3)//1461 ! D=4*D+3-1461*K ! D=(D+4)//4 ! M=(5*D-3)//153 ! D=5*D-3-153*M ! D=(D+5)//5 ! Y=K *lss_k; *iad_693902 *imy_4; *isb_1; *imdv_146097 *lss_ %tos; *idv_4; *imy_4; *iad_3 *imdv_1461; *st_(y) *lss_ %tos; *iad_4; *idv_4 *imy_5; *isb_3; *imdv_153 *st_(m); *lss_ %tos *iad_5; *idv_5; *st_(d) %if m < 10 %then m = m + 3 %else m = m - 9 %and y = y + 1 !bish%if m<10 %then m=m+3 %elsestart !bish m=m-9 !bish %if y=99 %then y=0 %else y=y+1 !bish%finish %end; ! OF KDATE %integer %fn current secs !! GIVES CURRENT DT IN NEW PACKED FORM %const %long %integer mill = 1000000 *rrtc_0; *ush_-1 *shs_1; *ush_1 *imdv_mill *isb_secs70; *stuh_ %b !*OR_X'80000000' *exit_-64 %end %routine decwrite2(%integer value, ad) !! WRITES VALUE AS TWO DECIMAL ISO DIGITS INTO AD AND AD+1 *lss_value; *imdv_10 *ush_8; *iad_ %tos; *iad_x'3030' *lda_ad; *ldtb_x'58000002' *st_(%dr ) %end; ! OF DECWRITE2 %string(19) %fn secs to dt(%integer p) !! Converts secs to a date/time string. %integer h, m, at, d, mo, y, ad, secs %string(9) dat %string(8) tim %string(19) all %const %string(3) %array month(1:12) = %c "Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec" at = addr(tim) tim = "00:00:00" *lss_p; *ush_1; *ush_-1 *imdv_60; *imdv_60; *imdv_24 *lss_ %tos; *st_h *lss_ %tos; *st_m *lss_ %tos; *st_secs decwrite2(h, at + 1) decwrite2(m, at + 4) decwrite2(secs, at + 7) ad = addr(dat) dat = "00 XXX 00" p = (p & x'7FFFFFFF') // secs in 24 hrs kdate(d, mo, y, p + days70) string(ad + 2) = " ".month(mo) decwrite2(d, ad + 1) decwrite2(y, ad + 8) !%result = dat." ".tim all = dat." ".tim length(all) = 16; !get rid of seconds length(all) = 9 %if substring(all, 12, 16) = "00:00"; !get rid of null hours and mins %result = all %end; !OF SECS TO DT %integer %fn analyse dt after(%string(255) datestring) !! Analyses a string specifying when a message is to be delivered. !! This routine based on DEC-10 code %integer msg day, msg month, msg year, msg minutes !RESULTS OF ANALYSIS %integer pt, value, state, datestate, token, dateerror %integer secs now, days now, d, m, y, i %integer todays weekday, days from now %switch action(0:5) %switch subact(0:4) %const %integer %array mnemonic time value(0:5) = %c 8*60,12*60,12*60,16*60,20*60,23*60+59 !! Breakfast, lunch, noon, tea, dinner, midnight %const %byte %integer %array monthlength(1:12) = %c 31,28,31,30,31,30,31,31,30,31,30,31 %routine dateparse !! Takes tokens from "datetoken" and tries to make sense of them !! Transition table for parsing numeric/mnemonic months !! States are across the top, syntactic classes are vertical !! Class: 0 = number, 1 = time(number), 2 = month %const %byte %integer %array datetab(0:5,0:2) = %c 1, 2, 2, 2, 0, 5, 4, 4, 4, 4, 5, 5, 3, 2, 5, 5, 3, 5 ! 0 1 2 3 4 5 !! Action table for number/mnemonic date %const %byte %integer %array dateact(0:5,0:2) = %c 1, 2, 3, 1, 5, 8, 4, 4, 4, 4, 8, 8, 6, 7, 8, 8, 7, 8 ! 0 1 2 3 4 5 %switch sw(0:8) ->sw(dateact(state, token)) sw(1): !A PLAIN NUMBER IS A DATE msg day = value ->sw(0) sw(2): !SECOND NUMBER IS A MONTH msg month = value ->sw(0) sw(3): !YEAR %if value > 99 %then msg year = value %else msg year = value + 1900 ->sw(0) sw(4): !HOURS msg minutes = value * 60 ->sw(0) sw(5): !MINUTES msg minutes = msg minutes + value ->sw(0) sw(6): !MONTH ALONE SETS DAY TO 1 msg day = 1 sw(7): !MONTH AFTER DAY JUSTS SETS MONTH msg month = value ->sw(0) sw(8): !ERROR dateerror = 1 sw(0): !DO NOTHING state = datetab(state, token) %end; !OF DATE PARSE %integer %fn date token !! This routine returns the next token from the input string. !! Character classes: !! 0 = space !! 1 = A-Z !! 2 = 0-9 !! 3 = ( !! 4 = ) !! 5 = : . !! 6 = rest !! 7 = end of string %const %byte %integer %array class(' ':'Z') = %c 0,6(7),3,4,6(4),5,6,2(10),5,6(6),1(26) !! In the state transition table, these character classes are across the !! top, the following states are vertical: !! 0 = startup !! 1 = scan till ")" or end !! 2 = build keyword !! 3 = build number !! 4 = delete blanks %const %byte %integer %array dateparsenext(0:7,0:4) = %c 0, 62, 62, 1, 63, 63, 63, 63, 1, 2, 3, 1, 4, 1, 1, 63, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 3, 1, 1, 1, 1, 1, 4, 63, 63, 63, 63, 63, 63, 63 ! sp A-Z 0-9 ( ) : rest end !! Action table %const %byte %integer %array dateparseact(0:7,0:4) = %c 0, 5, 5, 0, 5, 5, 5, 5, 0, 1, 2, 0, 0, 0, 0, 5, 6, 1, 6, 6, 6, 6, 6, 6, 3, 3, 2, 3, 3, 4, 3, 3, 0, 5, 5, 5, 5, 5, 5, 5 %const %string(9) %array datekeyword(1:34) = %c "JANUARY","FEBRUARY","MARCH","APRIL","MAY","JUNE","JULY", "AUGUST","SEPTEMBER","OCTOBER","NOVEMBER","DECEMBER", "SUNDAY","MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY", "TODAY","TOMORROW","WEEK","MONTH","YEAR", "BREAKFAST","LUNCH","NOON","TEA","DINNER","MIDNIGHT", "AFTER","SINCE","AT","NEXT" %integer cl, char, act, i %string(255) str, rest %switch sw(0:6) str = "" value = 0 %cycle pt = pt + 1 %if pt > length(datestring) %then cl = 7 %else %start char = charno(datestring, pt) %if ' ' <= char <= 'Z' %then cl = class(char) %else cl = 7 %finish act = dateparseact(cl, datestate) datestate = dateparsenext(cl, datestate) ->sw(act) sw(0): !DO NOTHING %continue sw(1): !CONCATENATE CHAR str = str.tostring(char) %continue sw(2): !BUILD DECIMAL NUMBER value = value * 10 + char - '0' %continue sw(3): !RETURN NUMBER pt = pt - 1; !RESCAN CHAR %result = 0; !TOKEN = 0 sw(4): !RETURN TIME SPEC %result = 1 sw(5): !RETURN END OF DATE pt = pt - 1; !RESCAN CHAR %result = - 1 sw(6): !STRING - DECODE IT pt = pt - 1; !RESCAN CHAR value = - 1 %for i = 34, - 1, 1 %cycle %if start of(datekeyword(i), str, rest) = 1 %start %if value # - 1 %then value = - 2 %and %exit value = i %finish %repeat %if value < 0 %start %if value = - 1 %then printstring("Unknown") %else %c printstring("Ambiguous") printstring(" date/time keyword: ".str.snl) dateerror = - 1 %finish %else %start %if value < 13 %then %result = 2; !MONTH NAME %if value < 20 %then value = value - 13 %and %result = 3 !TODAYS WEEKDAY %if value < 25 %then value = value - 20 %and %result = 4 !MNEMONICDATE %if value < 31 %then value = value - 25 %and %result = 5 !MNEMONIC TIME %finish; !OTHERWISE NOISE value = 0 str = "" %repeat %end; !OF DATETOKEN datestring = "TODAY" %if datestring = "NOW" %or datestring = "" secs now = current secs days now = secs now // secs in 24 hrs kdate(d, m, y, days now + days70) y = y + 1900 msg day = d msg year = y msg month = m msg minutes = 0 state = 0 datestate = 0 dateerror = 0 pt = 0 todays weekday = (days now - 3) - ((days now - 3) // 7) * 7 days from now = 0 datestring <- "(".datestring.")" %cycle token = datetoken %if token = - 1 %then %exit ->action(token) action(0): !NUMBER action(1): !TIME action(2): !MONTH dateparse %continue action(3): !TODAYS WEEKDAY days from now = value - todays weekday %if days from now <= 0 %then days from now = days from now + 7 %continue action(4): !MNEMONIC DATES ->subact(value) subact(0): !TODAY %continue subact(1): !TOMORROW days from now = 1 %continue subact(2): !NEXT WEEK days from now = 7 - todays weekday %continue subact(3): !NEXT MONTH msg month = msg month + 1 msg day = 1 %if msg month > 12 %then msg month = 1 %and msg year = msg year + 1 %continue subact(4): !NEXT YEAR msg year = msg year + 1 msg day = 1 msg month = 1 %continue action(5): !MNEMONIC TIMES msg minutes = mnemonic time value(value) %repeat %if dateerror = 0 %and pt # length(datestring) %then dateerror = 1 %if dateerror # 0 %start %if dateerror # - 1 %then %c printstring("Faulty date/time specification".snl) %result = - 1 %finish %if msg minutes >= 24 * 60 %start printstring("Invalid time in date/time specification".snl) %result = - 1 %finish %if days from now = 0 %start %unless 0 < msg month <= 12 %start printstring("Invalid month in date specification".snl) %result = - 1 %finish i = monthlength(msg month) %if msg month = 2 %and msg year = (msg year >> 2) << 2 %then i = i + 1 %unless 0 < msg day <= i %start printstring("Month has only ".itos(i)." days".snl) %result = - 1 %finish %if msg month > 2 %then msg month = msg month - 3 %else %c msg month = msg month + 9 %and msg year = msg year - 1 i = 1461 * (msg year - 1900) // 4 + (153 * msg month + 2) %c // 5 + msg day + 58 - days70 %result = i * secs in 24 hrs + msg minutes * 60 %finish %else %start %if msg day # d %or msg month # m %or msg year # y %start printstring("Inconsistent date/time specification".snl) %result = - 1 %finish %result = (days now + days from now) * secs in 24 hrs + msg minutes * 60 %finish %end; !OF ANALYSE DT AFTER %routine ps(%string(255) s) %string(255) a, b %integer width, i width = uinfi(15) a = s." " %cycle i = 1, 1, length(a) charno(a, i) = ' ' %if charno(a, i) = 10 %repeat start: %if length(a) > width %start %cycle i = width, - 1, 1 %exit %if charno(a, i) = ' ' %repeat b = substring(a, 1, i - 1) a = substring(a, i + 1, length(a)) printstring(b) newline ->start %finish %else %start printstring(a) newline %finish %end %routine memohelp(%integer i) %const %integer maxhelps=5 %switch helpsw(1:maxhelps) %integer j %if 1 <= i <= maxhelps %then j = i %else j = 1 ->helpsw(j) helpsw(1): ps(" The MEMO command allows you to store 10 short (up to 255 character) memos for your future reference. Use ADDMEMO to insert them, DELMEMO to delete them and MEMO to read them.") ps(" Each of these commands when followed by a question mark (?) will give some information about their use.") ps(" Put the command MEMO in your startfile for easy reference to your memos") ps(" The command MEMO will only list the memos that require action unless an asterisk is given as the parameter. MEMO * will list all your memos.") %return helpsw(2): ps(" The command ADDMEMO can be used to add a memo of up to 255 characters to your SS#PROFILE file. It should be called without parameters and will prompt for the information it requires.") ps(" The message should be typed in response to the ""Text:"" prompt and terminated with a tilde (~). When the message is typed out it will not recognise any breaks in lines that you may have typed so do not rely on any particular layout of the message.") ps(" If you try to type in more than 255 characters the excess will be ignored and you will be told that this has happened.") ps(" You will be prompted for the time at which you want to be reminded of the contents of the memo.") helpsw(3): ps(" Possible responses are ""now"",""today"",""friday"",""next week"", ""June"",""next year"",""23/05/84"",""23.50"" etc. If you give no relpy the memo will be noted for immediate action.") %return helpsw(4): ps(" The command DELMEMO may be given either with no parameters or parameters of one of the following types: a question mark (?), an asterisk (*), or a list of numbers.") ps(" The question mark will signify that you want help and this text will be printed, the numbers represent the numbers of the memos you want to delete, and the asterisk that ALL memos are to be deleted.") ps(" If you do not know the numbers of the memos you want to delete then give the command DELMEMO with no parameter and all memos currently stored will be listed to your terminal. You will then be asked if there are any you want to delete.") helpsw(5): ps("Please reply ""y""(es) or ""n""(o). If you replied no then you will be prompted for a list of the memo numbers to be deleted.") %return %end %integer %fn get time after %string(255) s %integer i, time now s = ""; i = 0 time now = current secs prompt("When for:") %if nextsymbol # nl %start skipsymbol %while nextsymbol # nl %finish skipsymbol s = s.tostring(nextsymbol) %and skipsymbol %while nextsymbol # nl %if s="?" %then memohelp(3) %andresult=get time after s = ucstring(s) i = analyse dt after(s) i = time now %if i <= 0 skipsymbol %if i > time now %then %c printstring("Memo set for action after :".secstodt(i)) %else %c printstring("Memo will not be delayed") newline %result = i %end %routine profile fail(%integername flag,%integer rw) pprofile !rw=1 if reading and 0 if writing profile %conststring(12)%array prof function(0:1)="Writeprofile","Readprofile" %switch failno(0:17) %if 0#rw#1 %then ps("Profile fail routine passed bad param!!!") %andstop %unless 0<=flag<=7 %start ps(prof function(rw)." fails with unknown flag ".itos(flag)) ps("Contact advisory") %stop %finish ->failno(flag+10*rw) failno(0): failno(10): !ie no error at all %return failno(1): ps("File SS#PROFILE Created ") flag=0 %return failno(2): ps("Failed to create SS#PROFILE - information not stored") %return failno(3): failno(4): ps("Failed to access SS#PROFILE - information not stored") %return failno(5): ps("SS#PROFILE is full - information not stored") %return failno(6): ps("Attempt to store too large a record in SS#PROFILE ". %c "- information not stored ") ps("Contact the writer of this program!!!!") %return failno(7): failno(17): ps("Attempt to access null key in SS#PROFILE ") ps("Contact the author of this program!!!!") %return failno(8): failno(9): !should have been caught already but just in case %return failno(11): failno(12): ps("Information in SS#PROFILE was wrong size!!!!!") ps("Contact the writer of this program!!!!") flag=0 !because some information may be vaild!!! %return failno(13): ps("SS#PROFILE does not exist - no information stored") %return failno(14): !field not found ! ps("Key not found in SS#PROFILE - no information stored") %return failno(15): ps("SS#PROFILE has been corrupted and must be destroyed") %return %end;!of profile fail %external %routine addmemo(%string(255) s) setpar(s) %if parmap#0 %then memohelp(2)%andreturn read profile(profile key, profile value, vsn, flag) !write(flag,1) %if flag#0;!@@ MUST GET BETTER REPORTING THAN THAT!!! %integer i, j i = 1 %while i < maxmemos + 1 %cycle %if profile value_after(i) = 0 %then %exit i = i + 1 %repeat %if i > maxmemos %then %c printstring("MEMO Fails - memo file full") %and %return prompt("text:") j = 1 s = "" printstring("Input text of memo, terminate with a ~ ") newline %while nextsymbol # '~' %and i < 255 %cycle s = s.tostring(nextsymbol) skipsymbol j = i + 1 %repeat %if j = 255 %start printstring("Warning - memo too long - has been truncated") newline %finish skipsymbol profile value_after(i) = get time after profile value_text(i) = s write profile(profile key, profile value, vsn, flag) profile fail(flag,0) ps("Memo number ".itos(i)." inserted") %if flag=0 %end; !of addmemo %external %routine memo(%string(255) s) %integer i vsn = profile vsn %if s="?" %then memohelp(1) %andreturn read profile(profile key,profile value,vsn,flag) profile fail(flag,1) %returnunless flag=0 prof read= 1 %for i = 1, 1, maxmemos %cycle %if profile value_after(i) # 0 %start %if s = "*" %start printstring("Memo no:"); write(i, 1); printstring(" for action after ".secstodt(profile value_after(i))) newline ps(profile value_text(i)) newline %finish %else %start %if profile value_after(i) <= current secs %start printch(7) printstring("**MEMO for ") printstring(secstodt(profilevalue_after(i))) newline ps(profile value_text(i)) newline %finish %finish %finish %repeat %end; !checkmemo %external %routine delmemo(%string(255) s) %integer delwanted, number to delete %string(255) ss setpar(s) %if parmap = 0 %start memo("*") %returnunless flag=0 printstring("Do you want to delete any of these ?") prompt("Yes/No?") newline get answer: skipsymbol %while nextsymbol # 'y' %and nextsymbol # 'n' %c %and nextsymbol#'Y' %and nextsymbol#'N' %and nextsymbol#nl %if nextsymbol=nl %then memohelp(5) %and -> get answer delwanted = 0 delwanted = 1 %if nextsymbol = 'Y' %or nextsymbol = 'y' skipsymbol %while nextsymbol # nl %return %if delwanted = 0 prompt("Numbers of memos to delete:") skipsymbol s = "" %while nextsymbol # nl %cycle s = s.tostring(nextsymbol) skipsymbol %repeat setpar(s) %finish again: ss = spar(0) %if ss="?" %start memohelp(4) %if prof read = 0 %thenreturnelse ->out %finish ->out %if ss = "" delmemo("1,2,3,4,5,6,7,8,9,10") %andreturn %if ss = "*" number to delete = pstoi(ss) %if %not 0 < number to delete <= maxmemos %start printstring("Invalid memo ".ss) newline ->again %finish readprofile(profile key, profile value, vsn, flag) %if prof read = 0 profile fail(flag,1) %stopunless flag=0 prof read = 1 profile value_after(number to delete) = 0 profile value_text(number to delete) = "" ->again out: write profile(profile key, profile value, vsn, flag) profile fail(flag,0) %stopunless flag=0 %end; !getmemo %end %of %file