BCPL example (copied from Applecorn)

ROMs/BCPL/ENCODEB

@@ -0,0 +1,41 @@
+SECTION "ENCODE"
+GET "LIBHDR"
+
+MANIFEST $( avsize = 20 $)
+
+LET start() BE
+$( LET ch = ?
+   LET infile, outfile = ?, ?
+   LET argvec = VEC avsize
+
+   IF RDARGS("FROM/A,TO/A", argvec, avsize) = 0 THEN
+      STOP(11)  // invalid arguments
+
+   infile := FINDINPUT(argvec!0)
+   IF infile = 0 THEN
+      STOP(RESULT2) // invalid in file
+   outfile := FINDOUTPUT(argvec!1)
+   IF outfile = 0 THEN
+      STOP(RESULT2) // invalid out file
+
+   SELECTINPUT(infile)
+   SELECTOUTPUT(outfile)
+
+   ch := RDCH()
+   WHILE ch NE endstreamch DO
+   $( WRCH( codechar(ch) )
+      ch := RDCH()
+   $)
+
+   ENDREAD()  // not strictly necessary
+   ENDWRITE() // but good practice
+$)
+
+AND codechar(char) = VALOF
+$( TEST 'A' <= char <= 'Z' THEN
+      char := 'A' + 'Z' - char
+   ELSE IF 'a' <= char <= 'z' THEN
+      char := 'a' + 'z' - char
+   RESULTIS char
+$)
+

ROMs/BCPL/EXMP1B

@@ -0,0 +1,97 @@
+section "EXMP1"
+
+needs "sound"     // sections from LIB
+needs "envelope"
+needs "adval"
+needs "vdu"
+needs "time"
+
+get "exmphdr"     // header file
+
+// This section of EXAMPLE contains START plus various
+// utility routines.
+
+let start() be
+$( // Select teletext mode and write double-height cyan heading.
+
+   mode(7)
+   for i = 0 to 1 do    // write 2 identical lines (double height)
+      writes("*x86*x8D           E X A M P L E*n")
+                        // '*x86' gives character 86 (hex)
+
+   // Write list of options in white.
+
+   writes("*nEnter*X88T*X89(Tune)*n")
+   writes(  "     *X88V*X89(Voltmeter)*n")
+   writes(  "     *X88X*X89(Exit)*n*n")
+   writes(  "then press*x88RETURN")
+
+   $( // Enter loop to get valid input. Discard any characters left
+      // over from previous input, blank out previous input then prompt.
+
+      while testflags(more.input) do rdch()
+      txtcursor(0, 12)
+      for i = 1 to 40 do wrch('*S')
+      txtcursor(0, 12)
+      writes("? ")
+
+      // Process the input, taking notice of the first character only.
+
+      switchon capch(rdch()) into
+      $( case 'T':
+            playtune()
+            break // jumps out of inner repeat loop
+
+         case 'V':
+            voltmeter()
+            break
+
+         case 'X':
+            wrbin(12)   // clear screen
+            stop(0)     // and exit
+      $)
+
+      // If input invalid issue a flashing magenta error message and
+      // loop back to re-issue prompt.
+
+      txtcursor(0, 15)
+      writes("*x85*x88Please enter T, V or X*n")
+   $) repeat
+
+   // Come here on return from PLAYTUNE or VOLTMETER. Repeat the whole
+   // procedure.
+
+$) repeat
+
+
+// COLOUR sets the text colour (not in mode 7).
+
+and colour(col) be
+   vdu("17,%", col)
+
+
+// GCOL sets the graphics colour (not in mode 7).
+
+and gcol(gmode, col) be
+   vdu("18,%,%", gmode, col)
+
+
+// HIDECURSOR conceals the cursor.
+
+and hidecursor() be
+   vdu("23,1,0;0;0;0;")
+
+
+// PLOT has the same effect as the BASIC command PLOT.
+
+and plot(k, x, y) be
+   vdu("25,%,%;%;", k, x, y)
+
+
+// TXTCURSOR positions the text cursor.
+
+and txtcursor(x, y) be
+   vdu("31,%,%", x, y)
+
+.        // '.' marks end of section
+

ROMs/BCPL/EXMP2B

@@ -0,0 +1,139 @@
+section "EXMP2"
+
+get "exmphdr"
+
+// This section of EXAMPLE contains the procedure to play a tune.
+
+
+// PLAYTUNE uses the ENVELOPE and SOUND procedures to play a simple tune. The
+// tune is stored in a string. Each note is represented by 3 characters - the
+// octave number, the note (a-g) and +, - or space for sharp, flat or
+// natural. The note is in lower case for a quaver and upper case for a
+// crotchet. The first note in a bar is preceded by '!'. The string is assumed
+// to be valid.
+
+let playtune() be
+$( let envnumber = 1          // envelope to use
+   let pitch = ?              // pitch parameter for SOUND
+   let sbuffsz = adval(-6)    // size of sound buffer 1 (number of free slots)
+   let soundvec = vec 3       // parameter for SOUND
+   let tune = "!3b-*
+              *!4e-4e-4e-4e-4e-4e-*
+              *!4d 4f 4b-4b-4a-4f *
+              *!4e-4e-4e-4e-4d 4e-*
+              *!4f 3b-3b-3B-3b-*
+              *!4e-4e-4e-4e-4e-4e-*
+              *!4d 4f 4b-4b-4a-4f *
+              *!4g 4b-4e-4f 4e-4f *
+              *!4e-3e-3e-3E-"
+
+   // NOTEVAL is a table of the pitch for the notes in one octave,
+   // starting with A and taking C as 0.
+
+   let noteval = table 36, 44, 0, 8, 16, 20, 28
+
+   // Set up screen display then set up envelopes. Envelope 1
+   // is for quaver. Envelope 2 is for crotchet. Envelope 3
+   // is for accented quaver at start of bar. (There are no
+   // accented crotchets.)
+
+   dodisplay()
+   envelope(table 1, 2, 0, 0, 0, 0, 0, 0, 30,  -2, -127, -127, 120, 105)
+   envelope(table 2, 2, 0, 0, 0, 0, 0, 0, 60,  -6,  -30, -127, 120,  60)
+   envelope(table 3, 2, 0, 0, 0, 0, 0, 0, 64, -10,  -65, -127, 126,  59)
+
+   soundvec!0 := 1         // initialise channel number
+
+   // Process each character in the tune string.
+
+   for i = 1 to tune%0 do
+   $( let ch = tune%i
+
+      test '1' <= ch <= '7' then
+
+      // Octave number - initialise pitch.
+         pitch := 48*(ch-'0') - 91
+
+      else test 'a' <= ch <= 'g' then
+
+      // Note (quaver) - update pitch and leave envelope as 1 (or 3).
+         pitch := pitch + noteval!(ch-'a')
+
+      else test 'A' <= ch <= 'G' then
+
+      // Note (crotchet) - update pitch and select envelope 2.
+      $( pitch := pitch + noteval!(ch-'A')
+         envnumber := 2
+      $)
+
+      else test ch = '!' then
+
+      // Start of bar so set envelope 3 for following note.
+         envnumber := 3
+
+      else
+
+      // Assume '+', '-' or space so adjust pitch for sharp or
+      // flat if appropriate then play the note.
+      $( test ch = '+' then
+            pitch := pitch + 4
+         else if ch = '-' then
+            pitch := pitch - 4
+
+         soundvec!1 := envnumber
+         soundvec!2 := pitch
+         soundvec!3 := envnumber = 2 -> 6, 3 // duration (longer for crotchet)
+         sound(soundvec)
+
+         envnumber := 1    // reset envelope number to quaver.
+      $)
+   $)                      // back for next character
+
+   // All notes put in buffer. Wait until they have been played
+   // before returning to the menu.
+
+   until adval(-6) = sbuffsz loop      // wait for tune to end
+$)
+
+
+// DISPNOTE displays a note symbol in flashing white at a specified x position.
+
+and dispnote(x) be
+$( let chartab = table 160,160,234,228,   // 4x5 array of graphics chars
+                       141,160,234,160,   // double height
+                       141,160,234,160,
+                       160,248,254,160,
+                       160,181,234,160,
+                       160,171,167,160
+   for i=0 to 5 do
+   $( txtcursor(x, 3+i)    // position character on line 3
+      wrbin(136)           // flashing
+      wrbin(151)           // graphic white
+      for j=4*i to 4*i+3 do
+         wrbin(chartab!j)
+      wrbin(137)           // steady
+   $)
+$)
+
+
+// DODISPLAY sets up the display.
+
+and dodisplay() be
+$( mode(7)
+   for i = 0 to 1 do       // double height title
+   $( txtcursor(10, i+4)
+      writes("*x8D*x81*x9D*x86M U S I C  *x9C")
+   $)
+   dispnote(1); dispnote(29)        // note symbols
+   txtcursor(1, 10)
+   for i = 0 to 14 do
+   $( wrbin(129 + (i rem 3))        // select one of three colours
+      writes("MUSIC")
+      wrbin(10)                     // cursor down then 4 left
+      for j = 1 to 4 do wrbin(8)
+   $)
+   txtcursor(0, 23)        // leave cursor at end of screen
+$)
+.
+
+