Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume23/abc/part07

Internet Message Format | 1991-01-08 | 54.1 KB

Subject:  v23i086:  ABC interactive programming environment, Part07/25
Newsgroups: comp.sources.unix
Approved: [e-mail]
X-Checksum-Snefru: d3fb3d1f f1ec7d0d bf88903f f25840a8

Submitted-by: Steven Pemberton <[e-mail]>
Posting-number: Volume 23, Issue 86
Archive-name: abc/part07

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then feed it
# into a shell via "sh file" or similar.  To overwrite existing files,
# type "sh file -c".
# The tool that generated this appeared in the comp.sources.unix newsgroup;
# send mail to [e-mail] if you want that tool.
# Contents:  abc/abc.hlp abc/bint2/i2gen.c abc/bint3/i3bws.c
#   abc/ex/try/position.abc
# Wrapped by [e-mail] on Mon Dec 17 13:27:57 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
echo If this archive is complete, you will see the following message:
echo '          "shar: End of archive 7 (of 25)."'
if test -f 'abc/abc.hlp' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'abc/abc.hlp'\"
else
  echo shar: Extracting \"'abc/abc.hlp'\" \(20503 characters\)
  sed "s/^X//" >'abc/abc.hlp' <<'END_OF_FILE'
XSUMMARY OF SPECIAL ACTIONS
X
X  :name   Visit how-to called 'name'
X  :       Visit last how-to refered to
X  ::      Display headings of how-to's in this workspace
X
X  =name   Visit contents of location
X  =       Visit last location visited
X  ==      Display names of permament locations in this workspace
X
X  >name   Visit workspace 'name'
X  >       Visit last workspace visited
X  >>      Display list of workspace names
X
X  QUIT    Leave ABC
X
XSUMMARY OF EDITING OPERATIONS
X
X  Name      Default Keys*    Short description
X
X  Accept    [TAB]            Accept suggestion, focus to hole or end of line
X  Return    [RETURN]         Add line or decrease indentation
X
X  Widen     f1, [ESC] w      Widen focus
X  Extend    f2, [ESC] e      Extend focus (usually to the right)
X  First     f3, [ESC] f      Move focus to first contained item
X  Last      f4, [ESC] l      Move focus to last contained item
X
X  Previous  f5, [ESC] p      Move focus to previous item
X  Next      f6, [ESC] n      Move focus to next item
X  Upline    f7, [ESC] u      Move focus to whole line above
X  Downline  f8, [ESC] d      Move focus to whole line below
X
X  Up        ^, [ESC] U       Make new hole, move up
X  Down      v, [ESC] D       Make new hole, move down
X  Left      <-, [ESC] ,      Make new hole, move left
X  Right     ->, [ESC] .      Make new hole, move right
X
X  Goto      [ctrl-G], mouseclick  New focus at cursor position
X
X  Undo      [BACKSPACE]      Undo effect of last key pressed (may be repeated)
X  Redo      [ctrl-U]         Redo last UNDOne key (may be repeated)
X
X  Copy      f9, [ctrl-C], [ESC]c  Copy buffer to hole, or focus to buffer
X  Delete    [ctrl-D]         Delete contents of focus (to buffer if empty)
X
X  Record    [ctrl-R]         Start/stop recording keystrokes
X  Play      [ctrl-P]         Play back recorded keystrokes
X
X  Look      [ctrl-L]         Redisplay screen
X  Help      f10, [ESC]?      Print summary of editing operations
X
X  Exit      [ctrl-X]         Finish changes or execute command
X  Interrupt (as set by 'stty')Interrupt command execution
X  Suspend (as set by 'stty') Suspend ABC (only for shell with job control)
X
X  * Notes:
X
X  [Ctrl-D] means: hold the [CTRL] (or [CONTROL]) key down while pressing d.
X  [ESC] w means: press the [ESC] key first, then w.
X
XABC QUICK REFERENCE
X
X  COMMANDS
X
X  WRITE expr                    Write to screen;
X                                / before or after expr gives new line
X  READ address EG expr          Read expression from terminal to address;
X                                expr is example
X  READ address RAW              Read line of text
X  PUT expr IN address           Put value of expr in address
X  SET RANDOM expr               Start random sequence for random and choice
X  REMOVE expr FROM list         Remove one element from list
X  INSERT expr IN list           Insert in right place
X  DELETE address                Delete permanent location or table entry
X  PASS                          Do nothing
X  KEYWORD expr KEYWORD ...      Execute user-defined command
X  KEYWORD                       Execute refined command
X
X  CHECK test                    Check test and stop if it fails
X  IF test:                      If test succeeds, execute commands;
X     commands                       no ELSE allowed
X  SELECT:                       Select one alternative:
X      test: commands                 try each test in order
X      ...                            (one must succeed;
X      test: commands                 the last test may be ELSE)
X  WHILE test:                   As long as test succeeds
X     commands                       execute commands
X  FOR name,... IN train:        Take each element of train in turn
X     commands
X
X  HOW-TO's
X
X  HOW TO KEYWORD ...:           Define new command KEYWORD ...
X     commands
X  HOW TO RETURN f:              Define new function f with no arguments
X     commands                      (returns a value)
X  HOW TO RETURN f x:            Define new function f with one argument
X     commands
X  HOW TO RETURN x f y:          Define new function f with two arguments
X     commands
X  HOW TO REPORT pr:             Define new predicate pr with no arguments
X     commands                      (succeeds/fails)
X  HOW TO REPORT pr x:           Define new predicate pr with one argument
X     commands
X  HOW TO REPORT x pr y:         Define new predicate pr with two arguments
X     commands
X
X  SHARE name,...                Share permanent locations
X                                (before commands of how-to)
X
X  Refinements (after the commands of a how-to)
X
X  KEYWORD : commands            Define command refinement
X  name: commands                Define expression- or test-refinement
X
X  Terminating commands
X
X  QUIT                          Leave command how-to or command refinement,
X                                or leave ABC
X  RETURN expr                   Leave function how-to or expression refinement,
X                                return value of expr
X  REPORT test                   Leave predicate how-to or test-refinement,
X                                report outcome of test
X  SUCCEED                       The same, report success
X  FAIL                          The same, report failure
X
X  EXPRESSIONS AND ADDRESSES
X
X  666, 3.14, 3.14e-9            Exact constants
X
X  expr,expr,...                 Compound
X  name,name,...                 Naming (may also be used as address)
X
X  text@p                        "ABCD"@2 = "BCD" (also address)
X  text|q                        "ABCD"|3 = "ABC" (also address)
X  text@p|q                      "ABCD"@2|1 = "BCD"|1 = "B"
X
X  table[expr]                   Table selection (also address)
X
X  "Jan", 'Feb', 'Won''t!'       Textual displays (empty: "" or '')
X  "value = `expr`;"             Conversion of expr to text
X
X  {1; 2; 2; ...}                List display (empty: {})
X  {1..9; ...}, {"a".."z"; ...}  List of consecutive values
X
X  {["Jan"]: 1; ["Feb"]: 2; ...} Table display (empty: {})
X
X  f, f x, x f y                 Result of function f (no permanent effects)
X  name                          Result of refinement (no permanent effects)
X
X  TESTS
X
X  x < y, x <= y, x >= y, x > y  Order tests
X  x = y, x <> y                      (<> means 'not equals')
X  0 <= d < 10
X
X  pr, pr x, x pr y              Outcome of predicate pr (no permanent effects)
X  name                          Outcome of refinement (no permanent effects)
X
X  test AND test AND ...         Fails as soon as one of the tests fails
X  test OR test OR ...           Succeeds as soon as one of the tests succeeds
X  NOT test
X
X  SOME name,... IN train HAS test
X                                Sets name, ... on success
X  EACH name,... IN train HAS test
X                                Sets name, ... on failure
X  NO   name,... IN train HAS test
X                                Sets name, ... on failure
X
X  PREDEFINED FUNCTIONS AND PREDICATES
X
X  Functions and predicates on numbers
X
X  ~x                            Approximate value of x
X  exactly x                     Exact value of x
X  exact x                       Test if x is exact
X  +x, x+y, x-y, -x, x*y, x/y    Plain arithmetic
X  x**y                          x raised to the power y
X  root x, n root x              Square root, n-th root
X  abs x, sign x                 Absolute value, sign (= -1, 0, or +1)
X  round x, floor x, ceiling x   Rounded to whole number
X  n round x                     x rounded to n digits after decimal point
X  a mod n                       Remainder of a on division by n
X  */x                           Numerator of exact number x
X  /*x                           Denominator
X  random                        Random approximate number r, 0 <= r < 1
X  e, exp x                      Base of natural logarithm, exponential function
X  log x, b log x                Natural logarithm, logarithm to the base b
X  pi, sin x, cos x, tan x, arctan x
X                                Trigonometric functions, with x in radians
X  angle (x, y), radius (x, y)   Angle of and radius to point (x, y)
X  c sin x, c cos x, c tan x     Similar, with the circle divided into c parts
X  c arctan x, c angle (x, y)        (e.g. 360 for degrees)
X  now                           e.g. (1999, 12, 31, 23, 59, 59.999)
X
X  Functions on texts
X
X  t^u                           t and u joined into one text
X  t^^n                          t repeated n times
X  lower t                       lower "aBc" = "abc"
X  upper t                       upper "aBc" = "ABC"
X  stripped t                    Strip leading and trailing spaces from t
X  split t                       Split text t into words
X
X  Function on tables
X
X  keys table                    List of all keys in table
X
X  Functions and predicates on trains
X
X  #train                        Number of elements in train
X  e#train                       Number of elements equal to e
X  e in train, e not.in train    Test for presence or absence
X  min train                     Smallest element of train
X  e min train                   Smallest element larger than e
X  max train, e max train        Largest element
X  train item n                  n-th element
X  choice train                  Random element
X
X  Functions on all types
X
X  x<<n                          x converted to text, aligned left in width n
X  x><n                          The same, centred
X  x>>n                          The same, aligned right
X
X  THE CHARACTERS
X
X   !"#$%&'()*+,-./              This is the order of all characters
X  0123456789:;<=>?              that may occur in a text.
X  @ABCDEFGHIJKLMNO              (The first is a space.)
X  PQRSTUVWXYZ[\]^_
X  `abcdefghijklmno
X  pqrstuvwxyz{|}~
X
XABC MANUAL
X
XNAME
X  abc - ABC interpreter & environment
X  abckeys - change key bindings for 'abc'
X
XSYNOPSIS
X  abc    [workspace and editor options]  [file ...]
X  abc    [workspace and task options]
X  abckeys
X
XDESCRIPTION
X  Without options or files, the ABC interpreter is started, using the ABC
X  editor, in the last workspace used or in workspace 'first' if this is
X  your first abc session.  A workspace is kept as a group of files in a
X  directory, with separate files for each how-to and location.  The
X  workspace directories themselves are kept by default in the directory
X  $HOME/abc.  On non-Unix machines, $HOME is the disk you are working on.
X
X  Workspace Options:
X
X  -W dir        use group of workspaces in 'dir' instead of $HOME/abc.
X
X  -w name       start in workspace 'name' instead of last workspace used.
X
X  -w path       use 'path' as workspace (no -W option allowed).
X
X  Editor option:
X
X  -e            Use $EDITOR as editor to edit definitions, instead of ABC
X                editor (Unix only).
X
X  file ...      Read commands from file(s) instead of from standard input;
X                input for READ commands is taken from standard input.  If a
X                file is called '-' and standard input is the keyboard, the
X                ABC system is started up interactively for that entry.
X
X  Special tasks:
X
X  -i tab        Fill table 'tab' with text lines from standard input
X
X  -o tab        Write text lines from table 'tab' to standard output
X
X  -l            List the how-to's in workspace on standard output
X
X  -r            Recover a workspace when its index is lost: useful after a
X                machine crash if the ABC internal administration files
X                didn't get written out.
X
X  -R            Recover the index of a group of workspaces
X
XUSAGE
X  (This is necessarily a very brief description; see 'The ABC Programmer's
X  Handbook' for full details.)
X
X  Use 'QUIT' to finish an ABC session.
X
X  When ABC starts up interactively, it displays a prompt and awaits input.
X
X  TYPING AND SUGGESTIONS: as you type, the system tries to suggest a
X  possible continuation for what you have typed; to accept the suggestion,
X  press [accept] (by default this is bound to the [TAB] key; type '?' to
X  find out the bindings for the keyboard you are using).  If you don't want
X  to accept the suggestion, just carry on typing (you can always type
X  character for character, ignoring the suggestions).  Usually the system
X  knows where a letter must be capital and where not, and you usually don't
X  have to use the shift key; however, in the few places where both a
X  lower-case and an upper-case letter would be legal (for instance for
X  AND), you have to type the letter upper-case.
X
X  When you type a control command, like WHILE, the system provides
X  indentation automatically for the body of the command; to reduce the
X  indentation one level, type [return].
X
X  CORRECTING AND EDITING: the [undo] key (by default bound to backspace)
X  undoes the last key you typed.  Repeatedly typing it undoes more and
X  more, up to a certain maximum number of keypresses.
X
X  To correct other parts, you must put the 'focus' onto the part you want
X  to change.  The focus is displayed by underlining or reverse video.
X  [Widen] and [extend] make the focus larger, [first] and [last] make it
X  smaller.
X
X  [Delete] deletes the contents of the focus.
X
X  [Copy] copies the contents of the focus to a buffer, or if the focus is
X  not focussed on anything, copies the contents of the buffer back to where
X  you are positioned.
X
X  MOVING THE FOCUS: [Upline] and [downline] focus on one line above or
X  below.  [Previous] and [next] move the focus left and right.  [Up],
X  [down], [left], and [right] move an empty focus around.  [Goto] widens
X  the focus to the largest thing at the current position.
X
X  OTHER OPERATIONS: [Look] redraws the screen; [record] records all
X  keystrokes until the next time you press [record] - [play] replays them.
X  [Redo] redoes the last key(s) undone; [interrupt] interrupts a running
X  command.
X
X  WORKSPACES: To create a new workspace, or go to an existing workspace,
X  type '>name'.  To go to the last workspace you were in, type a single
X  '>'.  To get a list of workspace names, type '>>'.
X
X  HOW-TO's: To create a new how-to, just type the first line of the how-to.
X  This creates the new how-to, and allows you to type the body.  Use [exit]
X  to finish it (by default [ESC][ESC]).
X
X  To visit a how-to, type a colon, followed by the name of the how-to.
X  Again, use [exit] to exit.  To visit the last how-to again, or the last
X  how-to you got an error message for, type a single ':'.  To get a list of
X  the how-to's in this workspace, type '::'.
X
X  To edit a location, type a '=' followed by the name of the location.  To
X  re-edit it, type a single '='.  To get a list of the locations in the
X  workspace, type '=='.
X
XKEY BINDINGS
X  The binding of editing operations like [accept] to keys may be different
X  for your keyboard; type a '?' at the prompt to find out what the bindings
X  are for your keyboard.
X  To redefine the keys used for editor operations, run 'abckeys'.  This
X  produces a private key definitions file.  You will be given instructions
X  on how to use it.
X  Keys labeled f1...f8 are function keys. On Unix, the way to type these is
X  terminal-dependent.  The codes they send must be defined by the termcap
X  entry for your terminal.
X  If a terminal has arrow keys which transmit codes to the computer, these
X  should be used for Up, Down, Left and Right.  Again, the termcap entry
X  must define the codes.
X  The Goto operation is of most use if the cursor can be moved locally at
X  the terminal, or if the terminal has a mouse; the Goto operation will
X  sense the terminal for the cursor or mouse position.  On Unix, we use two
X  extra non-standard termcap capabilities for this: 'sp' which gives the
X  string that must be sent to the terminal to sense the cursor position,
X  and 'cp' which defines the format of the reply (in the same format as
X  other cursor-addressing strings in termcap).  If your terminal's mouse-
X  click sends the position of the click automatically, just set 'sp' to the
X  empty string.  See termcap(5) for more details.
X
XFILES
X  $HOME/copybuf.abc        copy buffer between sessions
X  $HOME/abc/wsgroup.abc    table mapping workspace names to directory names
X  $HOME/abc/abckeys_$TERM  private key definitions file (Unix only)
X  $HOME/abc/abc.key        private key definitions file (non-Unix)
X  position.abc             focus position of edited how-to's in workspace
X  perm.abc                 table mapping object names to file names
X  suggest.abc              suggestion list for user-defined commands
X  types.abc                table with codes for typechecking between how-to's
X  *.cmd                    command how-to's in this workspace
X  *.zfd, *.mfd, *.dfd      function how-to's in this workspace
X  *.zpd, *.mpd, *.dpd      predicate how-to's in this workspace
X  *.cts                    permanent locations in this workspace
X  abc.msg                  messages file, used for errors (not on Macintosh)
X  abc.hlp                  helpfile with this text (MacABC.help on Macintosh)
X
X  The latter two are searched for first in your startup directory, then in
X  $HOME/abc, and finally, on Unix, in a directory determined by the
X  installer of ABC.  On the IBM PC and Atari ST the directories in your
X  $PATH are used in the last stage (if you have a hard disk place these
X  files in the workspaces directory abc).
X
XATARI ST IMPLEMENTATION
X  There are four files supplied: the program abc.tos itself, abckeys.tos
X  for changing your key bindings, the help file abc.hlp, and the error
X  messages file abc.msg.  (See FILES above.)
X  If you start ABC up from the desktop, and you want to use the options
X  given above, like -w, you should rename abc.tos to abc.ttp.  There is an
X  additional facility for redirecting input and output: the parameter
X  >outfile redirects all output from ABC to the file called outfile, and
X  similarly <infile takes its input from the file called infile.
X
XIBM PC IMPLEMENTATION
X  There are four files for running ABC, the program abc.exe itself,
X  abckeys.exe for changing your key bindings, the help file abc.hlp, and
X  the error messages file abc.msg.  (See FILES above.)
X  If your screen size is non-standard, or your machine is not 100% BIOS
X  compatible (which is unusal these days), you can specify the screen-size,
X  and whether to use the BIOS or ANSI.SYS for output, by typing after the
X  A> prompt, before you start ABC up, one of the following:
X       SET SCREEN=ANSI lines cols
X       SET SCREEN=BIOS lines cols
X  If you are going to use ANSI.SYS, be sure you have the line
X       DEVICE=ANSI.SYS
X  in your CONFIG.SYS file.  Consult the DOS manual for further details.
X
XAPPLE MACINTOSH IMPLEMENTATION
X  There are three files supplied: MacABC, the application itself,
X  MacABC.help, the help file, and MacABC.doc, a MacWrite document
X  containing a variant of this text.  The help file should be in the same
X  folder as MacABC, or in your System Folder.
X  MacABC runs in a single window.  You'll notice that most operations are
X  menu entries, as well as being possible from the keyboard.  You can start
X  ABC up by double-clicking the MacABC icon in which case you start up in
X  the last workspace used, or by double-clicking on any icon in a
X  workspace, in which case you start in that workspace.  In this latter
X  case, if the filename of the icon you clicked on ends in .cmd, that how-
X  to is executed, but the how-to may not have any parameters.
X  Instead of the special option flags mentioned above, most of the tasks,
X  like recovering a workspace, can be done from the File menu.
X  * Notes for Macintosh guru's:
X  The messages are STR# resources in MacABC; you must use a resource editor
X  to change them.
X  MacABC uses Monaco 9 for the screen, and Courier 10 for printing.  You
X  can change them with ResEdit, by editing the resource with type Conf and
X  ID 0.  The horizontal and vertical window-size and the window-title can
X  also be adapted there.  To facilitate this, first Paste the TMPL resource
X  with ID 5189 named Conf from MacABC to (a copy of) ResEdit.  But beware,
X  MacABC only works properly with Fixed-width Fonts like Monaco and
X  Courier.
X
XSEE ALSO
X  Leo Geurts, Lambert Meertens and Steven Pemberton, The ABC Programmer's
X       Handbook, Prentice-Hall, Englewood Cliffs, New Jersey, 1989,
X       ISBN 0-13-000027-2.
X  Steven Pemberton, An Alternative Simple Language and Environment for PCs,
X       IEEE Software, Vol. 4, No. 1, January 1987, pp. 56-64.
X  The ABC Newsletter. Available free from CWI.
X
XAUTHORS
X  Frank van Dijk, Leo Geurts, Timo Krijnen, Lambert Meertens, Steven
X  Pemberton, Guido van Rossum.
X
XADDRESS
X  ABC Distribution, CWI/AA, Postbox 4079, 1009 AB Amsterdam, The
X  Netherlands.
X  E-mail: '[e-mail]'.
X
END_OF_FILE
  if test 20503 -ne `wc -c <'abc/abc.hlp'`; then
    echo shar: \"'abc/abc.hlp'\" unpacked with wrong size!
  fi
  # end of 'abc/abc.hlp'
fi
if test -f 'abc/bint2/i2gen.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'abc/bint2/i2gen.c'\"
else
  echo shar: Extracting \"'abc/bint2/i2gen.c'\" \(19819 characters\)
  sed "s/^X//" >'abc/bint2/i2gen.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1986. */
X
X/* Code generation */
X
X#include "b.h"
X#include "bint.h"
X#include "feat.h"
X#include "bobj.h"
X#include "i0err.h"
X#include "i2nod.h"
X#include "i2gen.h" /* Must be after i2nod.h */
X#include "i2par.h"
X#include "i3env.h"
X#include "i3int.h"
X#include "i3sou.h"
X
XVisible Procedure fix_nodes(pt, code) parsetree *pt; parsetree *code; {
X    context c; value *setup(), *su;
X    sv_context(&c);
X    curline= *pt; curlino= one;
X    su= setup(*pt);
X    if (su != Pnil) analyze(*pt, su);
X    if (still_ok) no_mysteries();
X    curline= *pt; curlino= one;
X    inithreads();
X    fix(pt, su ? 'x' : 'v');
X    endthreads(code);
X    cleanup();
X#ifdef TYPE_CHECK
X    if (cntxt != In_wsgroup && cntxt != In_prmnv)
X        type_check(*pt);
X#endif
X    set_context(&c);
X}
X
XHidden Procedure no_mysteries() {
X    value names= keys(mysteries);
X    int i, n= length(names);
X    for (i= 1; i <= n; ++i) {
X        value name= thof(i, names);
X        value f;
X        if (!is_zerfun(name, &f)) {
X            value *aa= envassoc(mysteries, name);
X            if (locals != Vnil)
X                e_replace(*aa, &locals, name);
X            else
X                e_replace(zero, &globals, name);
X        }
X    }
X    release(names);
X}
X
X/* ******************************************************************** */
X
X/* Utilities used by threading. */
X
X/* A 'threaded tree' is, in our case, a fixed(*) parse tree with extra links
X   that are used by the interpreter to determine the execution order.
X   __________
X   (*) 'Fixed' means: processed by 'fix_nodes', which removes UNPARSED
X       nodes and distinguishes TAG nodes into local, global tags etc.
X       fix_nodes also creates the threads, but this is accidental, not
X       essential.  For UNPARSED nodes, the threads are actually laid
X       in a second pass through the subtree that was UNPARSED.
X   __________
X
X   A small example: the parse tree for the expression  'a+b*c'  looks like
X
X    (DYOP,
X        (TAGlocal, "a"),
X        "+",
X        (DYOP,
X            (TAGlocal, "b"),
X            "*",
X            (TAGlocal, "c"))).
X
X   The required execution order is here:
X
X    1) (TAGlocal, "a")
X    2) (TAGlocal, "b")
X    3) (TAGlocal, "c")
X    4) (DYOP, ..., "*", ...)
X    5) (DYOP, ..., "+", ...)
X
X   Of course, the result of each operation (if it has a result) is pushed
X   on a stack, and the operands are popped from this same stack.  Think of
X   reversed polish notation (well-known by owners of HP pocket calculators).
X
X   The 'threads' are explicit links from each node to its successor in this
X   execution order.  Conditional operations like IF and AND have two threads,
X   one for success and one for failure.  Loops can be made by having the
X   thread from the last node of the loop body point to the head of the loop.
X
X   Threading expressions, locations and simple-commands is easy: recursively
X   thread each of the subtrees, then lay a thread from the last threaded
X   to the current node.  Nodes occurring in a 'location' context are
X   marked, so that the interpreter knows when to push a 'location' on
X   the stack.
X
X   Tests and looping commands cause most of the complexity of the threading
X   utilities.  The basic technique is 'backpatching'.
X   Nodes that need a conditional forward jump are chained together in a
X   linked list, and when their destination is reached, all nodes in the
X   chain get its 'address' patched into their secondary thread.  There is
X   one such chain, called 'bpchain', which at all times contains those nodes
X   whose secondary destination would be the next generated instruction.
X   This is used by IF, WHILE, test-suites, AND and OR.
X
X   To generate a loop, both this chain and the last normal instruction
X   (if any) are diverted to the node where the loop continues.
X
X   For test-suites, we also need to be capable of jumping unconditionally
X   forward (over the remainder of the SELECT-command).  This is done by
X   saving both the backpatch chain and the last node visited, and restoring
X   them after the remainder has been processed.
X*/
X
X/* Implementation tricks: in order not to show circular lists to 'release',
X   parse tree nodes are generated as compounds where there is room for two
X   more fields than their length indicates.
X*/
X
X#define Flag (MkSmallInt(1))
X    /* Flag used to indicate Location or TestRefinement node */
X
XHidden parsetree start; /* First instruction.  Picked up by endthreads() */
X
XHidden parsetree last; /* Last visited node */
X
XHidden parsetree bpchain; /* Backpatch chain for conditional goto's */
XHidden parsetree *wanthere; /* Chain of requests to return next tree */
X
X#ifdef MSDOS
X#ifdef M_I86LM
X
X/* Patch for MSC 3.0 large model bugs... */
XVisible parsetree *_thread(p) parsetree p; {
X    return &_Thread(p);
X}
X
XVisible parsetree *_thread2(p) parsetree p; {
X    return &_Thread2(p);
X}
X
X#endif /* M_I86LM */
X#endif /* MSDOS */
X
X/* Start threading */
X
XHidden Procedure inithreads() {
X    bpchain= NilTree;
X    wanthere= 0;
X    last= NilTree;
X    here(&start);
X}
X
X/* Finish threading */
X
XHidden Procedure endthreads(code) parsetree *code; {
X    jumpto(Stop);
X    if (!still_ok) start= NilTree;
X    *code= start;
X}
X
X
X/* Fill 't' as secondary thread for all nodes in the backpatch chain,
X   leaving the chain empty. */
X
XHidden Procedure backpatch(t) parsetree t; {
X    parsetree u;
X    while (bpchain != NilTree) {
X        u= Thread2(bpchain);
X        Thread2(bpchain)= t;
X        bpchain= u;
X    }
X}
X
XVisible Procedure jumpto(t) parsetree t; {
X    parsetree u;
X    if (!still_ok) return;
X    while (wanthere != 0) {
X        u= *wanthere;
X        *wanthere= t;
X        wanthere= (parsetree*)u;
X    }
X    while (last != NilTree) {
X        u= Thread(last);
X        Thread(last)= t;
X        last= u;
X    }
X    backpatch(t);
X}
X
XHidden parsetree seterr(n) int n; {
X    return (parsetree)MkSmallInt(n);
X}
X
X/* Visit node 't', and set its secondary thread to 't2'. */
X
XHidden Procedure visit2(t, t2) parsetree t, t2; {
X    if (!still_ok) return;
X    jumpto(t);
X    Thread2(t)= t2;
X    Thread(t)= NilTree;
X    last= t;
X}
X
X/* Visit node 't' */
X
XHidden Procedure visit(t) parsetree t; {
X    visit2(t, NilTree);
X}
X
X/* Visit node 't' and flag it as a location (or test-refinement). */
X
XHidden Procedure lvisit(t) parsetree t; {
X    visit2(t, Flag);
X}
X
X#ifdef NOT_USED
XHidden Procedure jumphere(t) parsetree t; {
X    Thread(t)= last;
X    last= t;
X}
X#endif
X
X/* Add node 't' to the backpatch chain. */
X
XHidden Procedure jump2here(t) parsetree t; {
X    if (!still_ok) return;
X    Thread2(t)= bpchain;
X    bpchain= t;
X}
X
XHidden Procedure here(pl) parsetree *pl; {
X    if (!still_ok) return;
X    *pl= (parsetree) wanthere;
X    wanthere= pl;
X}
X
XVisible Procedure hold(pl) struct state *pl; {
X    if (!still_ok) return;
X    pl->h_last= last; pl->h_bpchain= bpchain; pl->h_wanthere= wanthere;
X    last= bpchain= NilTree; wanthere= 0;
X}
X
XVisible Procedure let_go(pl) struct state *pl; {
X    parsetree p, *w;
X    if (!still_ok) return;
X    if (last != NilTree) {
X        for (p= last; Thread(p) != NilTree; p= Thread(p))
X            ;
X        Thread(p)= pl->h_last;
X    }
X    else last= pl->h_last;
X    if (bpchain != NilTree) {
X        for (p= bpchain; Thread2(p) != NilTree; p= Thread2(p))
X            ;
X        Thread2(p)= pl->h_bpchain;
X    }
X    else bpchain= pl->h_bpchain;
X    if (wanthere) {
X        for (w= wanthere; *w != 0; w= (parsetree*) *w)
X            ;
X        *w= (parsetree) pl->h_wanthere;
X    }
X    else wanthere= pl->h_wanthere;
X}
X
XHidden bool reachable() {
X    return last != NilTree || bpchain != NilTree || wanthere != 0;
X}
X
X
X/* ******************************************************************** */
X/* *********************** code generation **************************** */
X/* ******************************************************************** */
X
XForward bool is_variable();
XForward bool is_cmd_ref();
XForward value copydef();
X
XVisible Procedure fix(pt, flag) parsetree *pt; char flag; {
X    struct state st; value v, function;
X    parsetree t, l1= NilTree, w;
X    typenode nt, nt1; string s; char c; int n, k, len;
X
X    t= *pt;
X    if (!Is_node(t) || !still_ok) return;
X    nt= Nodetype(t);
X    if (nt < 0 || nt >= NTYPES) syserr(MESS(2200, "fix bad tree"));
X    s= gentab[nt];
X    if (s == NULL) return;
X    n= First_fieldnr;
X    if (flag == 'x') curline= t;
X    while ((c= *s++) != '\0' && still_ok) {
X        switch (c) {
X        case '0':
X        case '1':
X        case '2':
X        case '3':
X        case '4':
X        case '5':
X        case '6':
X        case '7':
X        case '8':
X        case '9':
X            n= (c - '0') + First_fieldnr;
X            break;
X        case 'c':
X            v= *Branch(t, n);
X            if (v != Vnil) {
X                len= Nfields(v);
X                for (k= 0; k < len; ++k)
X                    fix(Field(v, k), flag);
X            }
X            ++n;
X            break;
X        case '#':
X            curlino= *Branch(t, n);
X            ++n;
X            break;
X        case 'g':
X        case 'h':
X            ++n;
X            break;
X        case 'a':
X        case 'l':
X            if (flag == 'v' || flag == 't')
X                c= flag;
X            /* Fall through */
X        case 'b':
X        case 't':
X        case 'u':
X        case 'v':
X        case 'x':
X            fix(Branch(t, n), c);
X            ++n;
X            break;
X        case 'f':
X            f_fpr_formals(*Branch(t, n));
X            ++n;
X            break;
X
X        case ':':    /* code for WHILE loop */
X            curlino= *Branch(t, WHL_LINO);
X            here(&l1);
X            visit(t);
X            fix(Branch(t, WHL_TEST), 't');
X            v= *Branch(t, WHL_SUITE);
X            if (nodetype((parsetree) v) != COLON_NODE)
X                syserr(BAD_WHILE);
X            visit(v);
X            fix(Branch(v, COLON_SUITE), 'x');
X            jumpto(l1);
X            jump2here(v);
X            break;
X
X        case ';':    /* code for TEST_SUITE */
X            if (*Branch(t, TSUI_TEST) == NilTree) {
X                sk_tsuite_comment(t, &w);
X                if (w != NilTree)
X                    fix(&w, 'x');
X                break;
X            }
X            curlino= *Branch(t, TSUI_LINO);
X            visit(t);
X            curline= *Branch(t, TSUI_TEST);
X            fix(Branch(t, TSUI_TEST), 't');
X            v= *Branch(t, TSUI_SUITE);
X            if (nodetype((parsetree) v) != COLON_NODE)
X                syserr(BAD_TESTSUITE);
X            visit2(v, seterr(1));
X            fix(Branch(v, COLON_SUITE), 'x');
X            hold(&st);
X            sk_tsuite_comment(t, &w);
X            if (w != NilTree) {
X                jump2here(v);
X                fix(&w, 'x');
X            }
X            let_go(&st);
X            break;
X
X        case '?':
X            if (flag == 'v')
X                f_eunparsed(pt);
X            else if (flag == 't')
X                f_cunparsed(pt);
X            else
X              syserr(MESS(2201, "fix unparsed with bad flag"));
X            fix(pt, flag);
X            break;
X        case '@':
X            f_trim_target(t, '@');
X            break;
X        case '|':
X            f_trim_target(t, '|');
X            break;
X        case 'C':
X            v= *Branch(t, REL_LEFT);
X            nt1= nodetype((parsetree) v);
X            if (Comparison(nt1))
X                jump2here(v);
X            break;
X        case 'D':
X            v= (value)*Branch(t, DYA_NAME);
X            if (!is_dyafun(v, &function))
X                fixerrV(NO_DEFINITION, v);
X            else
X                *Branch(t, DYA_FCT)= copydef(function);
X            break;
X        case 'E':
X            v= (value)*Branch(t, DYA_NAME);
X            if (!is_dyaprd(v, &function))
X                fixerrV(NO_DEFINITION, v);
X            else
X                *Branch(t, DYA_FCT)= copydef(function);
X            break;
X        case 'F':
X            if (*Branch(t, NUM_VALUE) == Vnil) {
X                *Branch(t, NUM_VALUE)=
X                numconst(*Branch(t, NUM_TEXT));
X            }
X            break;
X        case 'G':
X            jumpto(l1);
X            break;
X        case 'H':
X            here(&l1);
X            break;
X        case 'I':
X            if (*Branch(t, n) == NilTree)
X                break;
X            /* Else fall through */
X        case 'J':
X            jump2here(t);
X            break;
X        case 'K':
X            hold(&st);
X            break;
X        case 'L':
X            let_go(&st);
X            break;
X        case 'M':
X            v= (value)*Branch(t, MON_NAME);
X            if (is_variable(v) || !is_monfun(v, &function))
X                fixerrV(NO_DEFINITION, v);
X            else
X                *Branch(t, MON_FCT)= copydef(function);
X            break;
X        case 'N':
X            v= (value)*Branch(t, MON_NAME);
X            if (is_variable(v) || !is_monprd(v, &function))
X                fixerrV(NO_DEFINITION, v);
X            else
X                *Branch(t, MON_FCT)= copydef(function);
X            break;
X        case 'Q':    /* don't visit comment SUITE nodes */
X            if (*Branch(t, n) != NilTree)
X                visit(t);
X            break;
X#ifdef REACH
X        case 'R':
X            if (*Branch(t, n) != NilTree && !reachable())
X                fixerr(MESS(2202, "command cannot be reached"));
X            break;
X#endif
X        case 'S':
X            jumpto(Stop);
X            break;
X        case 'T':
X            if (flag == 't')
X                f_ctag(pt);
X            else if (flag == 'v' || flag == 'x')
X                f_etag(pt);
X            else
X                f_ttag(pt);
X            break;
X        case 'U':
X            f_ucommand(pt);
X            break;
X        case 'V':
X            visit(t);
X            break;
X        case 'X':
X            if (flag == 'a' || flag == 'l' || flag == 'b')
X                lvisit(t);
X            else
X                visit(t);
X            break;
X        case 'W':
X/*!*/            visit2(t, seterr(1));
X            break;
X        case 'Y':
X            if (still_ok && reachable()) {
X              if (nt == YIELD)
X                fixerr(YIELD_NO_RETURN);
X              else
X                fixerr(TEST_NO_REPORT);
X            }
X            break;
X        case 'Z':
X            if (!is_cmd_ref(t) && still_ok && reachable())
X  fixerr(MESS(2203, "refinement returns no value or reports no outcome"));
X              *Branch(t, REF_START)= copy(l1);
X            break;
X        }
X    }
X}
X
X/* skip test-suite comment nodes */
X
XHidden Procedure sk_tsuite_comment(v, w) parsetree v, *w; {
X    while ((*w= *Branch(v, TSUI_NEXT)) != NilTree &&
X                    Nodetype(*w) == TEST_SUITE &&
X            *Branch(*w, TSUI_TEST) == NilTree)
X        v= *w;
X}
X
X/* ******************************************************************** */
X
XHidden bool is_cmd_ref(t) parsetree t; { /* HACK */
X    value name= *Branch(t, REF_NAME);
X    string s;
X
X    if (!Valid(name))
X        return No;
X    s= strval(name);
X    /* return isupper(*s); */
X    return *s <= 'Z' && *s >= 'A';
X}
X
XVisible bool is_name(v) value v; {
X    if (!Valid(v) || !Is_text(v))
X        return No;
X    else {
X        string s= strval(v);
X        /* return islower(*s); */
X        return *s <= 'z' && *s >= 'a';
X    }
X}
X
XVisible value copydef(f) value f; {
X    if (f == Vnil || Funprd(f)->pre == Use) return Vnil;
X    return copy(f);
X}
X
XHidden bool is_basic_target(v) value v; {
X    if (!Valid(v))
X        return No;
X    return    locals != Vnil && envassoc(locals, v) != Pnil ||
X        envassoc(globals, v) != Pnil;
X}
X
XHidden bool is_variable(v) value v; {
X    value f;
X    if (!Valid(v))
X        return No;
X    return is_basic_target(v) ||
X        envassoc(refinements, v) != Pnil ||
X        is_zerfun(v, &f);
X}
X
XHidden bool is_target(p) parsetree *p; {
X    value v;
X    int k, len;
X    parsetree w, *left, *right;
X    typenode trimtype;
X    typenode nt= nodetype(*p);
X
X    switch (nt) {
X
X    case TAG:
X        v= *Branch(*p, First_fieldnr);
X        return is_basic_target(v);
X
X    case SELECTION:
X    case BEHEAD:
X    case CURTAIL:
X    case COMPOUND:
X        return is_target(Branch(*p, First_fieldnr));
X
X    case COLLATERAL:
X        v= *Branch(*p, First_fieldnr);
X        len= Nfields(v);
X        k_Overfields {
X            if (!is_target(Field(v, k))) return No;
X        }
X        return Yes;
X    case DYAF:
X        if (trim_opr(*Branch(*p, DYA_NAME), &trimtype)) {
X            left= Branch(*p, DYA_LEFT);
X            if (is_target(left)) {
X                right= Branch(*p, DYA_RIGHT);
X                w= node3(trimtype, copy(*left), copy(*right));
X                release(*p);
X                *p= w;
X                return Yes;
X            }
X        }
X        return No;
X
X    default:
X        return No;
X
X    }
X}
X
XHidden bool trim_opr(name, type) value name; typenode *type; {
X    value v;
X
X    if (!Valid(name))
X        return No;
X    if (compare(name, v= mk_text(S_BEHEAD)) == 0) {
X        release(v);
X        *type= BEHEAD;
X        return Yes;
X    }
X    release(v);
X    if (compare(name, v= mk_text(S_CURTAIL)) == 0) {
X        release(v);
X        *type= CURTAIL;
X        return Yes;
X    }
X    release(v);
X    return No;
X}
X
X/* ******************************************************************** */
X
X#define WRONG_KEYWORD    MESS(2204, "wrong keyword %s")
X#define NO_ACTUAL    MESS(2205, "missing actual parameter after %s")
X#define EXP_KEYWORD    MESS(2206, "can't find expected %s")
X#define ILL_ACTUAL    MESS(2207, "unexpected actual parameter after %s")
X#define ILL_KEYWORD    MESS(2208, "unexpected keyword %s")
X
XHidden Procedure f_actuals(formals, actuals) parsetree formals, actuals; {
X    /* name, actual, next */
X    parsetree act, form, next_a, next_f, kw, *pact;
X
X    do {
X        kw= *Branch(actuals, ACT_KEYW);
X        pact= Branch(actuals, ACT_EXPR); act= *pact;
X        form= *Branch(formals, FML_TAG);
X        next_a= *Branch(actuals, ACT_NEXT);
X        next_f= *Branch(formals, FML_NEXT);
X
X        if (compare(*Branch(formals, FML_KEYW), kw) != 0)
X            fixerrV(WRONG_KEYWORD, kw);
X        else if (act == NilTree && form != NilTree)
X            fixerrV(NO_ACTUAL, kw);
X        else if (next_a == NilTree && next_f != NilTree)
X            fixerrV(EXP_KEYWORD, *Branch(next_f, FML_KEYW));
X        else if (act != NilTree && form == NilTree)
X            fixerrV(ILL_ACTUAL, kw);
X        else if (next_a != NilTree && next_f == NilTree)
X            fixerrV(ILL_KEYWORD, *Branch(next_a, ACT_KEYW));
X        else if (act != NilTree)
X            act_expr_gen(pact, form);
X        actuals= next_a;
X        formals= next_f;
X    }
X    while (still_ok && actuals != NilTree);
X}
X
X/* Fix and generate code for an actual parameter.
X   This generates 'locate' code if it looks like a target,
X   or 'evaluate' code if the parameter looks like an expression.
X   The formal parameter's form is also taken into account:
X   if it is a compound, and the actual is also a compound,
X   the number of fields must match and the decision between 'locate'
X   and 'evaluate' code is made recursively for each field.
X   (If the formal is a compound but the actual isn't,
X   that's OK, since it might be an expression or simple location
X   of type compound.
X   The reverse is also acceptable: then the formal parameter has
X   a compound type.) */
X
XHidden Procedure act_expr_gen(pact, form) parsetree *pact; parsetree form; {
X    while (Nodetype(form) == COMPOUND)
X        form= *Branch(form, COMP_FIELD);
X    while (Nodetype(*pact) == COMPOUND)
X        pact= Branch(*pact, COMP_FIELD);
X    if (Nodetype(form) == COLLATERAL && Nodetype(*pact) == COLLATERAL) {
X        value vact= *Branch(*pact, COLL_SEQ);
X        value vform= *Branch(form, COLL_SEQ);
X        int n= Nfields(vact);
X        if (n != Nfields(vform))
X            fixerr(MESS(2209, "compound parameter has wrong length"));
X        else {
X            int k;
X            for (k= 0; k < n; ++k)
X                act_expr_gen(Field(vact, k), *Field(vform, k));
X            visit(*pact);
X        }
X    }
X    else {
X        if (is_target(pact))
X            f_targ(pact);
X        else
X            f_expr(pact);
X    }
X}
X
XHidden Procedure f_ucommand(pt) parsetree *pt; {
X    value t= *pt, *aa;
X    parsetree u, f1= *Branch(t, UCMD_NAME), f2= *Branch(t, UCMD_ACTUALS);
X    release(*Branch(t, UCMD_DEF));
X    *Branch(t, UCMD_DEF)= Vnil;
X    if ((aa= envassoc(refinements, f1)) != Pnil) {
X        if (*Branch(f2, ACT_EXPR) != Vnil
X                || *Branch(f2, ACT_NEXT) != Vnil)
X            fixerr(MESS(2210, "refinement with parameters"));
X        else *Branch(t, UCMD_DEF)= copy(*aa);
X    }
X    else if (is_unit(f1, Cmd, &aa)) {
X        u= How_to(*aa)->unit;
X        f_actuals(*Branch(u, HOW_FORMALS), f2);
X    }
X    else fixerrV(MESS(2211, "you haven't told me HOW TO %s"), f1);
X}
X
XHidden Procedure f_fpr_formals(t) parsetree t; {
X    typenode nt= nodetype(t);
X
X    switch (nt) {
X    case TAG:
X        break;
X    case MONF: case MONPRD:
X        f_targ(Branch(t, MON_RIGHT));
X        break;
X    case DYAF: case DYAPRD:
X        f_targ(Branch(t, DYA_LEFT));
X        f_targ(Branch(t, DYA_RIGHT));
X        break;
X    default:
X        syserr(MESS(2212, "f_fpr_formals"));
X    }
X}
X
XVisible bool modify_tag(name, tag) parsetree *tag; value name; {
X    value *aa, function;
X    *tag= NilTree;
X    if (!Valid(name))
X        return No;
X    else if (locals != Vnil && (aa= envassoc(locals, name)) != Pnil)
X        *tag= node3(TAGlocal, name, copy(*aa));
X    else if ((aa= envassoc(globals, name)) != Pnil)
X        *tag= node2(TAGglobal, name);
X    else if ((aa= envassoc(refinements, name)) != Pnil)
X        *tag= node3(TAGrefinement, name, copy(*aa));
X    else if (is_zerfun(name, &function))
X        *tag= node3(TAGzerfun, name, copydef(function));
X    else if (is_zerprd(name, &function))
X        *tag= node3(TAGzerprd, name, copydef(function));
X    else return No;
X    return Yes;
X}
X
XHidden Procedure f_etag(pt) parsetree *pt; {
X    parsetree t= *pt; value name= copy(*Branch(t, TAG_NAME));
X    if (modify_tag(name, &t)) {
X        release(*pt);
X        *pt= t;
X        if (Nodetype(t) == TAGzerprd)
X            fixerrV(MESS(2213, "%s cannot be used in an expression"), name);
X        else
X            visit(t);
X    } else {
X        fixerrV(NO_INIT_OR_DEF, name);
X        release(name);
X    }
X}
X
XHidden Procedure f_ttag(pt) parsetree *pt; {
X    parsetree t= *pt; value name= copy(*Branch(t, TAG_NAME));
X    if (modify_tag(name, &t)) {
X        release(*pt);
X        *pt= t;
X        switch (Nodetype(t)) {
X        case TAGrefinement:
X            fixerr(REF_NO_TARGET);
X            break;
X        case TAGzerfun:
X        case TAGzerprd:
X            fixerrV(NO_INIT_OR_DEF, name);
X            break;
X        default:
X            lvisit(t);
X            break;
X        }
X    } else {
X        fixerrV(NO_INIT_OR_DEF, name);
X        release(name);
X    }
X}
X
X#define NO_REF_OR_ZER    MESS(2214, "%s is neither a refined test nor a zeroadic predicate")
X
XHidden Procedure f_ctag(pt) parsetree *pt; {
X    parsetree t= *pt; value name= copy(*Branch(t, TAG_NAME));
X    if (modify_tag(name, &t)) {
X        release(*pt);
X        *pt= t;
X        switch (Nodetype(t)) {
X        case TAGrefinement:
X            lvisit(t); /* 'Loc' flag here means 'Test' */
X            break;
X        case TAGzerprd:
X            visit(t);
X            break;
X        default:
X            fixerrV(NO_REF_OR_ZER, name);
X            break;
X        }
X    } else {
X        fixerrV(NO_REF_OR_ZER, name);
X        release(name);
X    }
X}
END_OF_FILE
  if test 19819 -ne `wc -c <'abc/bint2/i2gen.c'`; then
    echo shar: \"'abc/bint2/i2gen.c'\" unpacked with wrong size!
  fi
  # end of 'abc/bint2/i2gen.c'
fi
if test -f 'abc/bint3/i3bws.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'abc/bint3/i3bws.c'\"
else
  echo shar: Extracting \"'abc/bint3/i3bws.c'\" \(10277 characters\)
  sed "s/^X//" >'abc/bint3/i3bws.c' <<'END_OF_FILE'
X/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1988. */
X
X#include "b.h"
X#include "bint.h"
X#include "bfil.h"
X#include "bmem.h"
X#include "bobj.h"
X#include "args.h"
X#include "feat.h"
X#include "i2par.h"
X#include "i3bws.h"
X#include "i3env.h"
X#include "i3sou.h"
X
X/* ******************************************************************** */
X/*        workspace routines                    */
X/* ******************************************************************** */
X
XVisible char *bwsdir= (char *) NULL;    /* group name workspaces */
X
XVisible value ws_group= Vnil;        /* index workspaces */
XVisible bool groupchanges= No;        /* if Yes index is changed */
X
XVisible value curwskey= Vnil;        /* special index key for cur_ws */
XVisible value lastwskey= Vnil;        /* special index key for last_ws */
X
XVisible value cur_ws= Vnil;        /* the current workspace */
X                    /* only visible for m1bio.c */
XHidden value last_ws= Vnil;        /* the last visited workspace */
X
XHidden bool path_workspace= No;        /* if Yes no workspace change allowed */
X
X#define gr_exists(name, aa) (in_env(ws_group, name, aa))
X#define def_group(name, f)  (e_replace(f, &ws_group, name), groupchanges= Yes)
X#define free_group(name)    (e_delete(&ws_group, name), groupchanges= Yes)
X
X#ifndef DIRMODE
X#define DIRMODE 0777
X#endif
X
X/* ******************************************************************** */
X
X#define DEFAULT_WS    "first"
X
X#define CURWSKEY    ">"
X#define LASTWSKEY    ">>"
X
XHidden Procedure initgroup() {
X    wsgroupfile= (string) makepath(bwsdir, WSGROUPFILE);
X    curwskey= mk_text(CURWSKEY);
X    lastwskey= mk_text(LASTWSKEY);
X    if (F_exists(wsgroupfile)) {
X        value fname= mk_text(wsgroupfile);
X        ws_group= getval(fname, In_wsgroup);
X        release(fname);
X        if (!still_ok) {
X            still_ok= Yes;
X            rec_wsgroup();
X        }
X
X    }
X    else ws_group= mk_elt();
X    groupchanges= No;
X}
X
XHidden Procedure endgroup() {
X    save_curlast(curwskey, cur_ws);
X    save_curlast(lastwskey, last_ws);
X    only_default();
X    put_wsgroup();
X}
X
XHidden Procedure save_curlast(wskey, ws) value wskey, ws; {
X    value *aa;
X
X    if (Valid(ws) && (!gr_exists(wskey, &aa) || (compare(ws, *aa) != 0)))
X        def_group(wskey, ws);
X}
X
X/*
X * removes the default entry if it is the only one;
X * the default is [CURWSKEY]: DEFAULT_WS;
X * this has to be done to create the possibility of removing an empty
X * wsgroupfile and bwsdefault directory;
X * still this will hardly happen (see comments in endbws() )
X */
X
XHidden Procedure only_default() {
X    value *aa;
X
X    if (length(ws_group) == 1 &&
X        Valid(curwskey) && gr_exists(curwskey, &aa)
X       ) {
X           value defws= mk_text(DEFAULT_WS);
X           if (compare(defws, *aa) == 0)
X               free_group(curwskey);
X           release(defws);
X    }
X}
X
XHidden Procedure put_wsgroup() {
X    value fn;
X    intlet len;
X
X    if (!groupchanges || !Valid(ws_group))
X        return;
X    fn= mk_text(wsgroupfile);
X    /* Remove the file if empty */
X    len= length(ws_group);
X    if (len == 0)
X        f_delete(fn);
X    else
X        putval(fn, ws_group, Yes, In_wsgroup);
X    release(fn);
X    groupchanges= No;
X}
X
X/* ******************************************************************** */
X
XHidden bool wschange(ws) value ws; {
X    value name, *aa;
X    bool new= No, changed;
X    char *path;
X
X    if (gr_exists(ws, &aa))
X        name= copy(*aa);
X    else {
X        name= new_fname(ws, Wsp);
X        if (!Valid(name))
X            return No;
X        new= Yes;
X    }
X    path= makepath(bwsdir, strval(name));
X    VOID Mkdir(path);
X    changed= chdir(path) == 0 ? Yes : No;
X    if (changed && new)
X        def_group(ws, name);
X    freepath(path);
X    release(name);
X    return changed;
X}
X
XHidden Procedure wsempty(ws) value ws; {
X    char *path, *permpath;
X    value *aa;
X
X    if (!gr_exists(ws, &aa))
X        return;
X    path= makepath(bwsdir, strval(*aa));
X    permpath= makepath(path, permfile);
X    if (F_exists(permpath));
X    else if (strcmp(startdir, path) == 0);
X    else if (rmdir(path) != 0);
X    else free_group(ws);
X    freepath(path);
X    freepath(permpath);
X}
X
X/* ******************************************************************** */
X
XVisible Procedure goto_ws() {
X    value ws= Vnil;
X    bool prname; /* print workspace name */
X
X    if (path_workspace) {
X        parerr(MESS(2900, "change of workspace not allowed"));
X        return;
X    }
X    if (Ceol(tx)) {
X        if (Valid(last_ws))
X            ws= copy(last_ws);
X        else
X            parerr(MESS(2901, "no previous workspace"));
X        prname= Yes;
X    }
X    else if (is_tag(&ws))
X        prname= No;
X    else
X        parerr(MESS(2902, "I find no workspace name here"));
X
X    if (still_ok && (compare(ws, cur_ws) != 0)) {
X        can_interrupt= No;
X        endworkspace();
X
X        if (wschange(ws)) {
X            release(last_ws); last_ws= copy(cur_ws);
X            release(cur_ws); cur_ws= copy(ws);
X        }
X        else {
X            parerrV(MESS(2903, "I can't goto/create workspace %s"), ws);
X            still_ok= Yes;
X            prname= No;
X        }
X
X        init_workspace(prname);
X        wsempty(last_ws);
X        can_interrupt= Yes;
X    }
X    release(ws);
X}
X
XVisible Procedure lst_wss() {
X    value wslist, ws;
X    value k, len, m;
X
X    if (path_workspace) {
X        print_wsname();
X        return;
X    }
X    wslist= keys(ws_group);
X
X    if (!in(cur_ws, wslist))
X        insert(cur_ws, &wslist);
X
X    k= one; len= size(wslist);
X    while (numcomp(k, len) <= 0) {
X        ws= item(wslist, k);
X        if (compare(ws, curwskey) == 0);
X        else if (compare(ws, lastwskey) == 0);
X        else if (compare(ws, cur_ws) == 0)
X            putSstr(stdout, ">%s ", strval(ws));
X        else
X            putSstr(stdout, "%s ", strval(ws));
X        release(ws);
X        k= sum(m= k, one);
X        release(m);
X    }
X    if (numcomp(len, zero) > 0)
X        putnewline(stdout);
X    fflush(stdout);
X    release(k); release(len);
X    release(wslist);
X}
X
X/************************************************************************/
X
X#define NO_PARENT    MESS(2905, "*** I cannot find parent directory\n")
X#define NO_WORKSPACE    MESS(2906, "*** I cannot find workspace\n")
X#define NO_DEFAULT    MESS(2907, "*** I cannot find your home directory\n")
X#define USE_CURRENT    MESS(2908, "*** I shall use the current directory as your single workspace\n")
X#define NO_ABCNAME    MESS(2909, "*** %s isn't an ABC name\n")
X#define TRY_DEFAULT    MESS(2910, "*** I shall try the default workspace\n")
X
XHidden Procedure wserr(m, use_cur) int m; bool use_cur; {
X    putmess(errfile, m);
X    if (use_cur)
X        wscurrent();
X}
X
XHidden Procedure wserrV(m, v, use_cur) int m; value v; bool use_cur; {
X    putSmess(errfile, m, strval(v));
X    if (use_cur)
X        wscurrent();
X}
X
XHidden Procedure wscurrent() {
X    putmess(errfile, USE_CURRENT);
X    path_workspace= Yes;
X}
X
X/* ******************************************************************** */
X
XHidden bool wsinit() {
X    value *aa;
X
X    initgroup();
X    cur_ws= Vnil;
X    last_ws= Vnil;
X    if (wsp_arg) {
X        /* wsp_arg is a single name here, not a pathname */
X#ifdef WSP_DIRNAME
X        /* on the mac wsp_arg is a mac foldername, not an ABC wsname */
X        cur_ws= abc_wsname(wsp_arg);
X        if (!Valid(cur_ws))
X            return No;
X#else
X        /* wsp_arg is here an ABC workspace name, not a path */
X        cur_ws= mk_text(wsp_arg);
X#endif
X        if (!is_abcname(cur_ws)) {
X            wserrV(NO_ABCNAME, cur_ws, No);
X            wserr(TRY_DEFAULT, No);
X            release(cur_ws); cur_ws= Vnil;
X        }
X    }
X    if (gr_exists(curwskey, &aa)) {
X        if (!Valid(cur_ws))
X            cur_ws= copy(*aa);
X        else if (compare(cur_ws, *aa) != 0)
X            last_ws= copy(*aa);
X        if (!Valid(last_ws) && gr_exists(lastwskey, &aa))
X            last_ws= copy(*aa);
X    }
X    if (!Valid(cur_ws))
X        cur_ws= mk_text(DEFAULT_WS);
X    if (!is_abcname(cur_ws))
X        wserrV(NO_ABCNAME, cur_ws, Yes);
X    else if (wschange(cur_ws)) {
X        path_workspace= No;
X        return Yes;
X    }
X    else wserr(NO_WORKSPACE, Yes);
X    return No;
X}
X
XVisible Procedure initbws() {
X    if (is_gr_reccall) { /* recover index of group workspaces */
X        if (!setbwsdir() || !D_exists(bwsdir)) {
X            wserr(NO_PARENT, No);
X            immexit(1);
X        }
X        initgroup();
X        return;
X    }
X    if (is_path(wsp_arg)) {
X        /* !bws_arg already assured in main.c */
X        if (chdir(wsp_arg) != 0)
X            wserr(NO_WORKSPACE, Yes);
X        else
X            path_workspace= Yes;
X    }
X    else if (setbwsdir()) {
X        if (!D_exists(bwsdir))
X            wserr(NO_PARENT, Yes);
X        else if (!wsinit())
X            wsrelease();
X    }
X    else wserr(NO_DEFAULT, Yes);
X    if (path_workspace) {
X        release(cur_ws);
X        cur_ws= mk_text(curdir());
X    }
X    init_workspace(Yes);
X}
X
XVisible Procedure endbws() {
X    if (!is_gr_reccall) {
X        endworkspace();
X        VOID chdir(startdir);
X        if (path_workspace) {
X            release(cur_ws);
X            cur_ws= Vnil;
X            return;
X        }
X        else wsempty(cur_ws);
X    }
X    /* else: only index of group workspaces recovered */
X
X    endgroup();
X    /*
X     * if the bwsdefault directory is used and empty, remove it;
X     * because of the savings of the last two visited workspaces
X     * in the file `bwsdefault`/`wsgroupfile` this will hardly happen;
X     * only if you stays for ever in the default workspace.
X     */
X    if (!bws_arg && bwsdefault)
X        VOID rmdir(bwsdefault); /* fails if not empty */
X    wsrelease();
X}
X
XVisible bool is_path(path) char *path; {
X    if (path == (char *) NULL)
X        return No;
X    if (strcmp(path, CURDIR) == 0 || strcmp(path, PARENTDIR) == 0)
X        return Yes;
X    for (; *path; path++) {
X        if (Isanysep(*path)) return Yes;
X    }
X    return No;
X}
X
XHidden bool setbwsdir() {
X    if (bws_arg || bwsdefault) {
X        if (!bws_arg) {
X            bwsdir= savepath(bwsdefault); /* full path name */
X            VOID Mkdir(bwsdir);
X        }
X        else if (!Isabspath(bws_arg))
X            bwsdir= makepath(startdir, bws_arg);
X        else
X            bwsdir= savepath(bws_arg);
X        return Yes;
X    }
X    return No;
X}
X
XHidden Procedure wsrelease() {
X    release(last_ws); last_ws= Vnil;
X    release(cur_ws); cur_ws= Vnil;
X    release(lastwskey); lastwskey= Vnil;
X    release(curwskey); curwskey= Vnil;
X    release(ws_group); ws_group= Vnil;
X    freepath(wsgroupfile); wsgroupfile= (string) NULL;
X    freepath(bwsdir); bwsdir= (char *) NULL;
X}
X
X/************************************************************************/
X
XHidden Procedure init_workspace(prname) bool prname; {
X    if (interactive && prname)
X        print_wsname();
X    initworkspace();
X    if (!still_ok) {
X        still_ok= Yes;
X        rec_workspace();
X    }
X}
X
XVisible Procedure initworkspace() {
X    initsou();
X    initfpr();
X    initenv();
X#ifdef USERSUGG
X    initsugg();
X#endif
X#ifdef SAVEPOS
X    initpos();
X#endif
X#ifdef TYPE_CHECK
X    initstc();
X#endif
X    setprmnv();
X    initperm();
X}
X
XVisible Procedure endworkspace() {
X    endperm();
X    endsou();
X    endenv();
X#ifdef USERSUGG
X    endsugg();
X#endif
X#ifdef SAVEPOS
X    endpos();
X#endif
X#ifdef TYPE_CHECK
X    endstc();
X#endif
X    enderro();
X}
X
X/************************************************************************/
X
XVisible bool wsp_writable() {
X    return F_writable(CURDIR) ? Yes : No;
X}
X
XHidden Procedure print_wsname() {
X    putSstr(errfile, ">%s\n", strval(cur_ws));
X    fflush(errfile);
X}
X
X/************************************************************************/
END_OF_FILE
  if test 10277 -ne `wc -c <'abc/bint3/i3bws.c'`; then
    echo shar: \"'abc/bint3/i3bws.c'\" unpacked with wrong size!
  fi
  # end of 'abc/bint3/i3bws.c'
fi
if test -f 'abc/ex/try/position.abc' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'abc/ex/try/position.abc'\"
else
  echo shar: Extracting \"'abc/ex/try/position.abc'\" \(12 characters\)
  sed "s/^X//" >'abc/ex/try/position.abc' <<'END_OF_FILE'
Xstart.cmd    4
END_OF_FILE
  if test 12 -ne `wc -c <'abc/ex/try/position.abc'`; then
    echo shar: \"'abc/ex/try/position.abc'\" unpacked with wrong size!
  fi
  # end of 'abc/ex/try/position.abc'
fi
echo shar: End of archive 7 \(of 25\).
cp /dev/null ark7isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 25 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still must unpack the following archives:
    echo "        " ${MISSING}
fi
exit 0 # Just in case...