A => COPYING +340 -0
@@ 1,340 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Library General
+Public License instead of this License.
A => ChangeLog +3 -0
@@ 1,3 @@
+2009-12-07: Dave Pitts <dpitts@cozx.com>
+
+ * Initial versioned release with GPL copyright.
A => Makefile +198 -0
@@ 1,198 @@
+#
+# Makefile for FOCAL
+#
+
+CFLAGS = -O -DUNIX -DANSICRT $(DEBUG)
+CC = gcc
+
+OBJ = .o
+
+#MVSCFLAGS = -O2 -DOPENEDITION -DANSICRT $(DEBUG)
+#MVSCC = gcc-uss
+MVSCFLAGS = -O2 -DOS390 $(DEBUG)
+MVSCC = gcc-mvsle
+MVSCOPTS = -S
+
+TARGETS = focal$(EXE)
+
+SRCS = focal.c parser.c screen.c
+OBJS = focal$(OBJ) parser$(OBJ) screen$(OBJ)
+SSRC = focal.s parser.s screen.s
+HDRS = parser.h errors.h ptables.h stables.h psemant.h scanner.h
+
+INSTDIR = /usr/local
+BINDIR = $(INSTDIR)/bin
+MANDIR = $(INSTDIR)/share/man/man1
+
+.c.s :
+ $(MVSCC) $(MVSCFLAGS) $(MVSCOPTS) $<
+ @mv $@ t.t
+ @detab 9 16 +8 t.t >$@
+ @rm t.t
+
+all :
+ @if [ "`uname -s`" = "Linux" ] ; then \
+ echo "Making Linux on a `uname -m`" ;\
+ make $(TARGETS) \
+ "CFLAGS = -O2 -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" ;\
+ elif [ "`uname -s`" = "GNU/kFreeBSD" ]; then \
+ echo "Making GNU/kFreeBSD on a `uname -m`";\
+ make $(TARGETS) \
+ "CFLAGS = -O2 -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" ;\
+ elif [ "`uname -s`" = "GNU" ] ; then \
+ echo "Making GNU/Hurd on a `uname -m`";\
+ make $(TARGETS) \
+ "CFLAGS = -O2 -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" ;\
+ elif [ "`uname -s`" = "OS/390" ] ; then \
+ echo "Making OS/390 USS" ;\
+ make $(TARGETS) "CC=cc" \
+ "CFLAGS = -O -DOPENEDITION -DSYSVDIR -DSTRERROR -DANSICRT \
+ $(DEBUG)" ;\
+ elif [ "`uname -s`" = "SunOS" ] ; then \
+ echo "Making Solaris" ;\
+ make $(TARGETS) \
+ "CFLAGS = -O -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" ;\
+ else \
+ echo "OS type `uname -s` is unknown" ;\
+ echo "You must enter an OS type. OS types are:" ;\
+ echo " linux | nt | openmvs | openvms | os2 | riscos | " ;\
+ echo " solaris | sunos | gnuhurd | gnukfreebsd" ;\
+ echo " " ;\
+ echo "For IBM OS/390 you have the choices:" ;\
+ echo " dignusdcc | dignusgcc | mvs" ;\
+ echo " " ;\
+ fi
+
+nt :
+ @nmake /nologo /f Makefile.nt $(PARM)
+
+openmvs :
+ @make focal$(EXE) \
+ "CFLAGS = -O -DOPENEDITION -DSYSVDIR -DSTRERROR -DANSICRT \
+ $(DEBUG)" \
+ "CC = cc" \
+ $(PARM)
+
+openvms vaxvms :
+ make /file=Makefile.vms $(PARM)
+
+os2 :
+ @nmake /nologo /f Makefile.os2 $(PARM)
+
+linux :
+ @make focal$(EXE) \
+ "CFLAGS = -O2 -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" \
+ $(PARM)
+
+gnuhurd :
+ @make focal$(EXE) \
+ "CFLAGS = -O2 -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" \
+ $(PARM)
+
+gnukfreebsd :
+ @make focal$(EXE) \
+ "CFLAGS = -O2 -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" \
+ $(PARM)
+
+solaris :
+ @make focal$(EXE) \
+ "CFLAGS = -O -DSYSVDIR -DSTRERROR -DANSICRT $(DEBUG)" \
+ $(PARM)
+
+sunos :
+ @make focal$(EXE) \
+ "CFLAGS = -O -DBSDDIR -DANSICRT $(DEBUG)" \
+ $(PARM)
+
+riscos :
+ @make focal$(EXE) \
+ "CFLAGS = -O -DBSDDIR -DANSICRT $(DEBUG)" \
+ $(PARM)
+
+focal$(EXE) : $(OBJS)
+ $(CC) -o $@ $(CFLAGS) $(OBJS) -lm
+
+mvs : $(SSRC)
+
+dignusdcc :
+ @make focal.po \
+ "LIBS = -lmvs" \
+ "CFLAGS = -DDIGNUS -DOS390 -I/usr/local/dignus/include $(DEBUG)" \
+ "CC = dcc"
+
+dignusgcc :
+ @make focal.po \
+ "LIBS = -lmvs" \
+ "CFLAGS = -S -DOS390 $(DEBUG)" \
+ "CC = gcc-mvsdignus"
+
+install :
+ @if [ ! -d $(BINDIR) ] ; then \
+ mkdir -p $(BINDIR) ;\
+ fi
+ cp $(TARGETS) $(BINDIR)
+ @if [ ! -d $(MANDIR) ] ; then \
+ mkdir -p $(MANDIR) ;\
+ fi
+ cp focal.1 $(MANDIR)
+
+clean :
+ rm -f $(OBJS) $(SSRC) core $(TARGETS)
+ rm -f *.obj *.asm *.po *.lst
+
+depend : $(SRCS)
+ mkdep $(SRCS) > makedep
+ @echo '/^# DO NOT DELETE THIS LINE/+1,$$d' >eddep
+ @echo '$$r makedep' >>eddep
+ @echo 'w' >>eddep
+ @cp Makefile Makefile.bak
+ @ex - Makefile < eddep
+ -@rm eddep makedep
+
+lint : $(SRCS)
+ lint $(SRCS)
+
+tags : $(SRCS)
+ ctags $(SRCS)
+
+focalc.tok focalc.err focalc.ptb focalc.sem : focalc.bnf
+ chat focalc
+
+perrors.h : focalc.err
+ cp focalc.err perrors.h
+
+ptables.h : focalc.ptb
+ cp focalc.ptb ptables.h
+
+psemant.h : focalc.sem
+ cp focalc.sem psemant.h
+
+ptokens.h : focalc.tok
+ cp focalc.tok ptokens.h
+
+focal.s : focal.c parser.h errors.h perrors.h
+parser.s : parser.c parser.h errors.h ptables.h stables.h psemant.h scanner.h
+screen.s : screen.c
+
+focal.asm : focal.c parser.h errors.h perrors.h
+ $(CC) $(CFLAGS) -o $@ $<
+parser.asm : parser.c parser.h errors.h ptables.h stables.h psemant.h scanner.h
+ $(CC) $(CFLAGS) -o $@ $<
+screen.asm : screen.c
+ $(CC) $(CFLAGS) -o $@ $<
+
+focal.obj : focal.asm
+ dasm -xa -xr -xrld -L /usr/local/dignus/maclib -macext . -o $@ $<
+parser.obj : parser.asm
+ dasm -xa -xr -xrld -L /usr/local/dignus/maclib -macext . -o $@ $<
+screen.obj : screen.asm
+ dasm -xa -xr -xrld -L /usr/local/dignus/maclib -macext . -o $@ $<
+
+focal.po : focal.obj parser.obj screen.obj
+ plink -px -o $@ focal.obj parser.obj screen.obj -L/usr/local/dignus/lib -lc $(LIBS)
+
+# DO NOT DELETE THIS LINE
+focal$(OBJ) : focal.c parser.h errors.h perrors.h
+parser$(OBJ) : parser.c parser.h errors.h ptables.h stables.h psemant.h \
+ scanner.h
+screen$(OBJ) : screen.c
A => Makefile.nt +31 -0
@@ 1,31 @@
+CPU = i386
+MAKECPU = /D_X86_
+PCPU = /G3
+
+!include <ntwin32.mak>
+
+EXE = .exe
+OBJ = .obj
+LIBEXT = .lib
+
+RM = del
+CP = copy
+
+EXELIBS = /nologo /SUBSYSTEM:console $(LDEBUG) netapi32.lib wsock32.lib
+
+CFLAGS = /nologo /DWIN32 /DANSICRT /DSTRERROR $(MAKECPU) $(DEBUG) /W3 /Zi /MD \
+ $(PCPU)
+
+FOCALOBJS = focal$(OBJ) parser$(OBJ) screen$(OBJ)
+
+all: focal$(EXE)
+
+focal$(EXE) : $(FOCALOBJS)
+ link $(TARGET) $(FOCALOBJS) $(EXELIBS)
+
+clean:
+ $(RM) $(FOCALOBJS) focal$(EXE)
+
+focal$(OBJ): focal.c parser.h errors.h perrors.h
+parser$(OBJ): parser.c parser.h errors.h ptables.h stables.h psemant.h scanner.h
+screen$(OBJ): screen.c
A => Makefile.os2 +27 -0
@@ 1,27 @@
+#
+# Make file for focal.
+#
+
+OBJ = .obj
+LIBEXT = .lib
+AR = ar
+RM = del
+CP = copy
+EXE = .exe
+
+CFLAGS = /DOS2 $(DEBUG) /Q+ /Ti+ /Gm+
+LINK = ilink/nofree
+
+FOCALOBJS = focal$(OBJ) parser$(OBJ) screen$(OBJ)
+
+all: focal$(EXE)
+
+focal$(EXE) : $(FOCALOBJS)
+ link $(TARGET) $(FOCALOBJS) $(EXELIBS)
+
+clean:
+ $(RM) $(FOCALOBJS) focal$(EXE)
+
+focal$(OBJ): focal.c parser.h errors.h perrors.h
+parser$(OBJ): parser.c parser.h errors.h ptables.h stables.h psemant.h scanner.h
+screen$(OBJ): screen.c
A => Makefile.vms +26 -0
@@ 1,26 @@
+EXE = .exe
+OBJ = .obj
+OPTS = runtime.opt
+LIBEXT = .olb
+SHLIBEXT = .olb
+
+RM = del
+CP = copy
+
+CFLAGS = /DEF=(VAXVMS,ANSICRT,STRERROR) $(DEBUG)
+
+FOCALOBJS := ( focal parser screen )$(OBJ)
+
+all : focal$(EXE)
+
+focal$(EXE) : $(FOCALOBJS)
+ link $(TARGET) $(FOCALOBJS), $(OPTS)/opt
+ @-purge/nolog
+
+clean :
+ -$(RM) *$(OBJ);*
+ -$(RM) *$(EXE);*
+
+focal$(OBJ) : focal.c parser.h errors.h perrors.h
+parser$(OBJ) : parser.c parser.h errors.h ptables.h stables.h psemant.h scanner.h
+screen$(OBJ) : screen.c
A => README +43 -0
@@ 1,43 @@
+Version: 1.0.0
+Date: 12/07/2009
+
+I. Introduction
+
+FOCAL is an interpretive language that was developed by Digital Equipment
+Corporation (DEC) in the late 1960's for their minicomputers. To learn the
+FOCAL language please refer to the DEC Programming Languages Handbook:
+
+http://www.bitsavers.org/pdf/dec/pdp8/handbooks/programmingLanguages_May70.pdf
+
+
+II. Building FOCAL
+
+To build FOCAL on Linux, z/OS OpenEdition or Solaris:
+
+ $ make
+
+To install:
+
+ $ make install
+
+
+To build FOCAL on OpenVMS:
+
+ $ @make
+
+
+III. Running FOCAL
+
+To run FOCAL interactively enter:
+
+ $ focal
+ FOCAL-1.0.0 execution begins
+ *
+
+FOCAL is now ready for operation.
+
+To run FOCAL with a program:
+
+ $ focal prog.foc
+
+This will start FOCAL, read the program, prog.foc, and start it.
A => asm.jcl +18 -0
@@ 1,18 @@
+//DPITTSAF JOB (0),'ASM.FOCAL',
+// MSGCLASS=X,TIME=(,20),NOTIFY=DPITTS
+//*
+//ASML PROC MEMBER=,OPT=
+//ASM EXEC PGM=ASMA90,REGION=2M,
+// PARM=('NODECK,OBJECT,NOESD,NORLD,NOXREF,LIST,&OPT')
+//SYSPRINT DD SYSOUT=*
+//SYSUNCH DD DUMMY
+//SYSLIB DD DSN=SYS1.MACLIB,DISP=SHR
+//SYSUT1 DD UNIT=SYSDA,SPACE=(CYL,(1,1)),DSN=&&UT1
+//SYSLIN DD DSN=DPITTS.TEST.OBJ(&MEMBER),DISP=SHR
+//SYSIN DD DSN=DPITTS.TEST.ASM(&MEMBER),DISP=SHR
+// PEND
+//*
+//FOCAL EXEC ASML,MEMBER=FOCAL
+//PARSER EXEC ASML,MEMBER=PARSER
+//SCREEN EXEC ASML,MEMBER=SCREEN
+//*
A => dampsine.foc +2 -0
@@ 1,2 @@
+05.10 FOR I=0,.5,30;T "*",!;FOR J=0,30+15*FSIN(I)*FEXP(-.1*I);T " "
+05.20 TYPE !; QUIT
A => diceg.foc +33 -0
@@ 1,33 @@
+01.05 T @E1.1
+01.10 S B=0;T !!"Dice Game"!,"House limit of $1000."
+01.13 T " Minimum bet is $1"!!
+01.14 T "Enter RETURN to roll dice."!
+01.15 T "To end game enter a negative bet."!
+01.20 A @10.1C"Your bet is"A;I (1000-A) 3.1
+01.21 I (A) 5.1
+01.22 I (A-1) 3.4
+01.26 I (A-FITR(A)) 3.5,1.3,3.5
+01.30 T @11.1C;D 2;S D=C;D 2;T !;S D=D+C
+01.31 T @12.1
+01.32 F Q=1,12;T @C!
+01.33 T @12.1;S Q=12
+01.35 I (D-7) 1.42,3.2,1.42
+01.40 I (D-2) 1.5,3.3,1.5
+01.42 I (D-11) 1.4,3.2,1.4
+01.50 I (D-3) 1.6,3.3,1.6
+01.60 T @12.1
+01.65 S Q=Q-1;I (Q) 1.31,1.66,1.66
+01.66 D 2;S E=C;D 2;T !;S E=E+C
+01.72 I (E-7) 1.74,3.3,1.74
+01.74 I (E-D) 1.65,3.2,1.65
+02.10 S C=FITR(6*FRAN(0)+1)
+02.20 T %2," "C
+03.10 T @9.20C"House limits are $1000";G 1.2
+03.20 S B=B+A;T @24.1C%7,"You WIN. Your winnings are"B;G 1.2
+03.30 S B=B-A;T @24.1C%7,"Sorry, you LOSE. You now have"B;G 1.2
+03.40 T @9.20C"Minimum bet is $1";G 1.2
+03.50 T @9.20C"NO pennies, please";G 1.2
+05.10 I (B) 5.5,5.3,5.2
+05.20 T @24.1C"You have WON"%5,B," dollars, collect from DEC"!;Q
+05.30 T @24.1C"You have come out unscathed, bye"!;Q
+05.50 T @24.1C"You have LOST"%5,FABS(B)," dollars, pay Dave"!;Q
A => errors.h +37 -0
@@ 1,37 @@
+/***********************************************************************
+* File = errors.h
+***********************************************************************/
+
+#define USER_STOP 0
+#define BAD_CMD 1
+#define LIBRARY_CMD 1
+#define COMMAND 2
+#define BAD_LINE 2
+#define GO_TARGET 1
+#define DO_TARGET 2
+#define BAD_VAR 3
+#define BAD_EXPR 4
+#define FOR_EXPR 1
+#define IF_EXPR 2
+#define TAB_EXPR 3
+#define BAD_FUNC 5
+#define BAD_STRING 6
+#define BAD_NUM 7
+#define MEM_OVERFLOW 8
+#define LINE_OVERFLOW 1
+#define SYMBOL_OVERFLOW 2
+#define STACK_OVERFLOW 3
+#define PARSE_ERROR 9
+#define SCAN_ERROR 10
+#define SCAN_SIGN 1
+#define SCAN_FRAC 2
+#define SCAN_EXPON 3
+#define INTERP_ERROR 11
+#define ZERO_DIVIDE 1
+#define NEG_SQRT 2
+#define NEG_LOG 3
+#define MODIFY_ERROR 12
+#define FILE_ERROR 13
+#define FPE_STOP 14
+#define UNDEF_FUNC 15
+
A => fact.foc +8 -0
@@ 1,8 @@
+01.10 s a=1
+01.15 a "Number",n
+01.18 i (n) 1.4,1.4
+01.20 f i=1,n;d 2
+01.30 t %3,n," Factorial ",%,a,!
+01.40 q
+02.10 s a=a*i
+02.20 r
A => focal.1 +24 -0
@@ 1,24 @@
+.TH focal "1" "December 9, 2009"
+.SH NAME
+focal \- interpreter for FOCAL
+.SH SYNOPSIS
+.B focal
+.RI [\fIfile\fP]
+.br
+.SH DESCRIPTION
+This manual page briefly documents the
+.B focal
+command. To run
+.B focal
+interactively, run it with no arguments. Alternatively, you can
+pass the name of a file to
+.B focal
+on the command line. This will start
+.B focal
+and execute the code in the file.
+.PP
+For information about the FOCAL programming language handbook, read the
+README distributed with this package.
+.SH AUTHOR
+.B focal
+was written by Dave Pitts <dpitts@cozx.com>.
A => focal.c +3001 -0
@@ 1,3001 @@
+#if defined(OS390)
+#pragma nomargins
+#pragma nosequence
+#endif
+
+/***********************************************************************
+*
+* FOCAL - A FOCAL language interpreter
+*
+* Copyright (c) 1978-2009 Dave Pitts <dpitts@cozx.com>
+*
+* FOCAL is language developed by Digital Equipment Corporation (DEC).
+* To learn FOCAL syntax refer to DEC Programming Languages Handbook:
+*
+* http://www.bitsavers.org/pdf/dec/pdp8/handbooks/programmingLanguages_May70.pdf
+*
+*
+* FOCAL is free software; you can redistribute it and/or modify it under
+* the terms of the GNU General Public License as published by the Free
+* Software Foundation; either version 2, or (at your option) any later
+* version.
+*
+* FOCAL is distributed in the hope that it will be useful, but WITHOUT ANY
+* WARRANTY; without even the implied warranty of MERCHANTABILITY or
+* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+* for more details.
+*
+* You should have received a copy of the GNU General Public License
+* along with FOCAL; see the file COPYING. If not, write to the Free
+* Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+* 02111-1307, USA.
+*
+***********************************************************************/
+
+#define VERSION "1.0.0"
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <signal.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+#include <errno.h>
+
+#if defined(BSDDIR) || defined(SYSVDIR)
+#include <sys/types.h>
+#include <sys/stat.h>
+#if defined(BSDDIR)
+#include <sys/dir.h>
+#endif
+#if defined(SYSVDIR)
+#include <dirent.h>
+#endif
+#endif
+
+#if defined(OS390)
+#include <stdlib.h>
+#endif
+
+#if defined(VAXVMS)
+#include <stsdef.h>
+#include <ssdef.h>
+#define NORMAL (SS$_NORMAL|STS$M_INHIB_MSG)
+#define ABORT (SS$_ABORT|STS$M_INHIB_MSG)
+#define STDERROUT "\n\n"
+#else /* VAXVMS */
+#define NORMAL 0
+#define ABORT 16
+#define STDERROUT "\n"
+#endif /* VAXVMS */
+
+#include "parser.h"
+#include "errors.h"
+
+#define EOL '\0' /* end of line */
+#define LINE_LEN 132 /* source line length */
+#define TWOCHAR 2 /* group/step sizes */
+#define PLEN 132 /* print buffer length */
+#define PBEG 2 /* print buffer start */
+
+#define DO_FLG 1
+#define FOR_FLG 2
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+
+#ifndef FALSE
+#define FALSE 0
+#endif
+
+#ifndef NULL
+#define NULL (void *)0
+#else
+#undef NULL
+#define NULL (void *)0
+#endif
+
+#define FOCAL_EXT ".foc"
+#define FOCAL_LST ".lst"
+
+
+/* Symbol node */
+typedef struct sym_node
+{
+ struct sym_node *sym_ptr;
+ tokval sym_value;
+ int sym_index;
+ char symbol[TWOCHAR+1];
+} sym_node_t;
+
+/* Line node */
+typedef struct line_node
+{
+ struct line_node *line_ptr;
+ char grp_num[TWOCHAR+1];
+ char stp_num[TWOCHAR+1];
+ char line_txt[LINE_LEN+1];
+} line_node_t;
+
+/* PC stack element */
+typedef struct pc_stk
+{
+ struct pc_stk *pc_ptr;
+ char *pc_index;
+ line_node_t *old_pc;
+ int pc_flags; /* DO_FLG, FOR_FLG */
+} pc_stk_t;
+
+/* FOR loop stack element */
+typedef struct for_stk
+{
+ struct for_stk *for_ptr;
+ tokval for_inc;
+ tokval for_limit;
+ char for_index[TWOCHAR+1];
+} for_stk_t;
+
+/* DO stack element */
+typedef struct do_stk
+{
+ struct do_stk *do_ptr;
+ int do_flag;
+ char do_grp[TWOCHAR+1];
+} do_stk_t;
+
+/* Static data */
+
+static line_node_t *buffer; /* pointer to buffer */
+static line_node_t *line_anchor; /* text lines anchor */
+static line_node_t *pc; /* the PC */
+static sym_node_t *sym_anchor; /* symbol table anchor */
+static pc_stk_t *pc_top; /* top of the PC stack */
+static for_stk_t *for_top; /* top of the FOR loop stack */
+static do_stk_t *do_top; /* top of the DO routine stack */
+static line_node_t *free_line; /* free lines */
+static sym_node_t *free_sym; /* free symbols */
+static for_stk_t *free_for; /* free for */
+static pc_stk_t *free_pc; /* free pcs */
+static do_stk_t *free_do; /* free dos */
+
+static int run_mode; /* program running mode 'GO' */
+static int do_mode; /* program in subroutine 'DO' */
+static int quit_flag; /* terminate FOCAL or program */
+static int trace_flag; /* trace program execution */
+static int user_stop; /* user keyboard interrupt */
+
+static int pndx; /* index into print buffer */
+static int width; /* print field width */
+static int digits; /* print field significance */
+static long seed; /* random number seed */
+
+static char *pcp; /* pointer into current PC line */
+static char tbuf[LINE_LEN+1];
+static char wd[LINE_LEN+1];
+
+static FILE *input;
+static FILE *output;
+static FILE *progfile;
+
+/* Function prototypes */
+
+static void askcmd (void);
+static void cleaner (void);
+static void continuecmd (void);
+static void docmd (void);
+static void erasecmd (void);
+static void execline (void);
+static tokval expression (void);
+static line_node_t *findline (void);
+static void forcmd (void);
+static void getgrp (char *);
+static void getstp (char *);
+static void gocmd (void);
+static void gotoit (void);
+static void getsym (char *);
+static void helpcmd (void);
+static void ifcmd (void);
+static void insertline (void);
+static void librarycmd (void);
+static void modifycmd (void);
+static void nextfield (void);
+static void pcpop (void);
+static void pcpush (void);
+static void quitcmd (void);
+static void returncmd (void);
+static void setcmd (void);
+static void typecmd (void);
+static void writecmd (void);
+
+extern long time (long *);
+
+void error (int, int);
+void symboltable (char *, tokval *, int, int);
+extern tokval Parser (char *);
+
+#if defined(ANSICRT)
+extern void clearline (void);
+extern void clearscreen (void);
+extern void screenposition (char *, char*);
+#endif
+
+#if defined(OS390)
+#define err_flag ERRFLAG
+#endif
+int err_flag;
+int fpe_stop; /* floating point exception */
+
+#ifdef DEBUG_FILE
+/***********************************************************************
+* HEXDUMP
+***********************************************************************/
+
+static void
+HEXDUMP (FILE *file, void *ptr, int size)
+{
+ int jjj;
+ int iii;
+ char *tp;
+ char *cp;
+ for (iii = 0, tp = (char *)(ptr), cp = (char *)(ptr); iii < (size); )
+ {
+ fprintf ((file), "%04x ", iii);
+ for (jjj = 0; jjj < 8; jjj++)
+ {
+ if (cp < ((char *)(ptr)+(size)))
+ {
+ fprintf ((file), "%02.2x", *cp++ & 0xFF);
+ if (cp < ((char *)(ptr)+(size)))
+ {
+ fprintf ((file), "%02.2x ", *cp++ & 0xFF);
+ }
+ else
+ {
+ fprintf ((file), " ");
+ }
+ }
+ else
+ {
+ fprintf ((file), " ");
+ }
+ iii += 2;
+ }
+ fprintf ((file), " ");
+ for (jjj = 0; jjj < 8; jjj++)
+ {
+ if (tp < ((char *)(ptr)+(size)))
+ {
+ if (isprint(*tp))
+ fprintf ((file), "%c", *tp);
+ else
+ fprintf ((file), ".");
+ tp++;
+ if (tp < ((char *)(ptr)+(size)))
+ {
+ if (isprint(*tp))
+ fprintf ((file), "%c ", *tp);
+ else
+ fprintf ((file), ". ");
+ tp++;
+ }
+ else
+ {
+ fprintf ((file), " ");
+ }
+ }
+ else
+ {
+ fprintf ((file), " ");
+ }
+ }
+ fprintf ((file), "\n");
+ }
+}
+#endif
+
+/***********************************************************************
+* upcase
+***********************************************************************/
+
+char
+upcase (char ch)
+{
+ if (islower (ch))
+ ch = toupper (ch);
+ return (ch);
+}
+
+/***********************************************************************
+* freedo - free a DO element
+***********************************************************************/
+
+static void
+freedo (do_stk_t *p)
+{
+ p->do_ptr = free_do;
+ free_do = p;
+} /* freedo */
+
+/***********************************************************************
+* freefor - free a FOR element
+***********************************************************************/
+
+static void
+freefor (for_stk_t *p)
+{
+ p->for_ptr = free_for;
+ free_for = p;
+} /* freefor */
+
+/***********************************************************************
+* freeline - free a line element
+***********************************************************************/
+
+static void
+freeline (line_node_t *p)
+{
+ p->line_ptr = free_line;
+ free_line = p;
+} /* freeline */
+
+/***********************************************************************
+* freesym - free a sym element
+***********************************************************************/
+
+static void
+freesym (sym_node_t *p)
+{
+ p->sym_ptr = free_sym;
+ free_sym = p;
+} /* freesym */
+
+/************************************************************************
+*
+* ASK - ask for user input
+*
+* Procedure ASK processes the ASK command. The forms recognized are
+* as follows:
+* A(SK) <var> ask for a variable
+* A(SK) "PROMPT",<var> ask for a variable w/prompting
+*
+************************************************************************/
+
+static void
+askcmd (void)
+{
+ tokval val;
+ int ndx;
+ int j;
+ char delim;
+ char row[TWOCHAR+1];
+ char col[TWOCHAR+1];
+ char sym[TWOCHAR+1];
+
+ /* Position to the next field */
+ nextfield();
+
+ do
+ {
+
+ /* Error if function */
+ if (upcase (*pcp) == 'F')
+ error (BAD_FUNC, 0);
+
+ /* Ask the value for input symbol */
+ else if (isalpha (*pcp))
+ {
+ getsym (sym);
+ ndx = 0;
+ if (*pcp == '(' || *pcp == '[' || *pcp == '<' || *pcp == '{')
+ {
+ /* Get subscript */
+ ndx = expression ();
+ }
+
+ /* Prompt for input */
+
+ fputs (":", stdout);
+#if defined(OS390) || defined(OS2)
+ fputc ('\n', stdout);
+ fflush (stdout);
+#endif
+
+ /* Read input */
+ fgets (tbuf, sizeof (tbuf), stdin);
+ if (tbuf[0] != '\n')
+ val = Parser (tbuf);
+ else
+ val = 0.0;
+
+ /* Save in symbol table */
+ symboltable (sym, &val, ndx, FALSE);
+ }
+
+ /* check for new line */
+ else if (*pcp == '!')
+ {
+ pcp++;
+ fputc ('\n', stdout);
+ }
+
+ /* check for prompt text */
+ else if (*pcp == '"' || *pcp == '\'')
+ {
+ delim = *pcp++;
+ if (trace_flag)
+ {
+ fputc (delim, output);
+ }
+ while (*pcp != EOL && *pcp != delim)
+ fputc (*pcp++, stdout);
+ if (*pcp == EOL)
+ error (BAD_STRING, 0);
+ else
+ pcp++;
+ if (trace_flag)
+ {
+ fputc (delim, output);
+ }
+ }
+
+ /* Position on CRT */
+ else if (*pcp == '@')
+ {
+ pcp++;
+ j = 0;
+ strcpy (row, "01");
+ strcpy (col, "01");
+ if (upcase (*pcp) == 'E')
+ {
+ pcp++;
+#if defined(ANSICRT)
+ clearscreen();
+#endif
+ }
+ if (isdigit (*pcp))
+ {
+ getgrp (row);
+ if (*pcp == '.')
+ {
+ pcp++;
+ getgrp (col);
+ }
+#if defined(ANSICRT)
+ screenposition (row, col);
+#endif
+ }
+ if (upcase (*pcp) == 'C')
+ {
+ pcp++;
+#if defined(ANSICRT)
+ clearline();
+#endif
+ }
+ }
+
+ else if (*pcp == EOL || *pcp == ';') ;
+
+ else pcp++;
+
+ } while (!err_flag && *pcp && *pcp != EOL && *pcp != ';');
+
+} /* ask */
+
+/************************************************************************
+*
+* CLEANER - Clean up after error
+*
+* This procedure cleans up after an error.
+*
+************************************************************************/
+
+static void
+cleaner (void)
+{
+ do_stk_t *p;
+ for_stk_t *q;
+
+ /* Write line number */
+ if (run_mode)
+ fprintf (stderr, " @ %s.%s", pc->grp_num, pc->stp_num);
+
+ /* Purge PC stack */
+ while (pc_top != NULL) pcpop();
+
+ /* Purge DO stack */
+ while (do_top != NULL)
+ {
+ p = do_top;
+ do_top = p->do_ptr;
+ freedo (p);
+ }
+
+ /* Purge FOR stack */
+ while (for_top != NULL)
+ {
+ q = for_top;
+ for_top = q->for_ptr;
+ freefor (q);
+ }
+
+ run_mode = FALSE;
+ do_mode = FALSE;
+
+ /* print error message */
+ fprintf (stderr, STDERROUT);
+
+ if (output != stdout)
+ fputs ("Errors in program execution\n", stdout);
+
+} /* cleaner */
+
+/************************************************************************
+*
+* CONTINUECMD - Continue/comment
+*
+* Procedure CONTINUE processes the CONTINUE/COMMENT command.
+*
+************************************************************************/
+
+static void
+continuecmd (void)
+{
+
+ while (*pcp && *pcp != ';' && *pcp != EOL) pcp++;
+
+} /* continuecmd */
+
+/************************************************************************
+*
+* DOCMD - DO subroutine command
+*
+* Procedure DOCMD process the DO command. The syntax is:
+* D(O) <GRP>[.<STP>]
+*
+************************************************************************/
+
+static void
+docmd (void)
+{
+ do_stk_t *p;
+ line_node_t *l;
+ int found;
+ char sym[TWOCHAR+1];
+
+ /* Position to group field */
+ nextfield();
+ if (*pcp == '?')
+ {
+ trace_flag = TRUE;
+ nextfield();
+ }
+
+ if (free_do == NULL)
+ {
+ if ((p = (do_stk_t *)malloc (sizeof (do_stk_t))) == NULL)
+ {
+ error (MEM_OVERFLOW, STACK_OVERFLOW);
+ }
+ }
+ else
+ {
+ p = free_do;
+ free_do = p->do_ptr;
+ }
+
+ if (p != NULL)
+ {
+
+ memset ((void *)p, '\0', sizeof (do_stk_t));
+
+ /* Get group from buffer */
+ getgrp (p->do_grp);
+ p->do_flag = TRUE;
+
+ /* Find group in line list */
+ l = line_anchor;
+ found = FALSE;
+ while (l != NULL && !found)
+ if (!strcmp (l->grp_num, p->do_grp))
+ found = TRUE;
+ else
+ l = l->line_ptr;
+
+ if (l != NULL)
+ {
+ /* Check for step */
+ if (*pcp == '.')
+ {
+ pcp++;
+ p->do_flag = FALSE;
+ getstp (sym); /* get step */
+ if (!err_flag)
+ {
+ found = FALSE;
+ while (l != NULL && !found)
+ if (!strcmp (p->do_grp, l->grp_num) &&
+ !strcmp (sym, l->stp_num))
+ found = TRUE;
+ else
+ l = l->line_ptr;
+ if (l == NULL)
+ {
+ error (BAD_LINE, DO_TARGET); /* bad line number */
+ freedo (p);
+ }
+ }
+ }
+
+ nextfield();
+ if (!err_flag)
+ {
+ /* Push where we are */
+ pcpush();
+ pc_top->pc_flags = DO_FLG;
+ pc = l;
+ pcp = pc->line_txt;
+ if (trace_flag)
+ {
+ fprintf (stdout, "\n+D%s.%s ", pc->grp_num, pc->stp_num);
+ }
+ /* Set up DO stack */
+ p->do_ptr = do_top;
+ do_top = p;
+ do_mode = TRUE;
+ }
+ }
+
+ else
+ {
+ error (BAD_LINE, DO_TARGET);
+ freedo (p);
+ }
+
+ }
+
+} /* docmd */
+
+/************************************************************************
+*
+* ERASECMD - Erase lines and symbols
+*
+* Procedure ERASE deletes the symbol table and program lines.
+*
+************************************************************************/
+
+static void
+erasecmd (void)
+{
+ sym_node_t *p, *p1;
+ line_node_t *q, *q1;
+ int found;
+ int k;
+ char grp[TWOCHAR+1], stp[TWOCHAR+1];
+
+ nextfield();
+ k = 2;
+
+ /* Erase symbol table */
+ if (*pcp == EOL || *pcp == ';')
+ k = 0;
+
+ /* Erase program and symbols */
+ else if (upcase (*pcp) == 'A')
+ {
+ nextfield();
+ k = 0;
+ q = line_anchor;
+ line_anchor = NULL;
+ while (q != NULL)
+ {
+ q1 = q->line_ptr;
+ freeline (q);
+ q = q1;
+ }
+ }
+
+ /* Erase specified lines */
+ else if (isdigit (*pcp))
+ {
+ k = 2;
+ getgrp (grp);
+ q = line_anchor;
+ q1 = line_anchor;
+ found = FALSE;
+
+ while (q != NULL && !found)
+ if (!strcmp (q->grp_num, grp))
+ found = TRUE;
+ else
+ {
+ q1 = q;
+ q = q->line_ptr;
+ }
+
+ if (q != NULL)
+ {
+ if (*pcp == '.')
+ {
+ pcp++;
+ getstp (stp);
+ found = FALSE;
+ if (!err_flag)
+ while (q != NULL && !found)
+ if (!strcmp (q->grp_num, grp) &&
+ !strcmp (q->stp_num, stp))
+ found = TRUE;
+ else
+ {
+ q1 = q;
+ q = q->line_ptr;
+ }
+ if (q != NULL)
+ if (q != line_anchor)
+ {
+ q1->line_ptr = q->line_ptr;
+ freeline (q);
+ }
+ else
+ {
+ line_anchor = q->line_ptr;
+ freeline (q);
+ }
+ }
+
+ else
+ {
+ found = FALSE;
+ if (q != line_anchor)
+ {
+ while (q != NULL && !found)
+ if (!strcmp (q->grp_num, grp))
+ {
+ q1->line_ptr = q->line_ptr;
+ freeline (q);
+ q = q1->line_ptr;
+ }
+ else found = TRUE;
+ }
+ else while (q != NULL && !found)
+ {
+ if (!strcmp (q->grp_num, grp))
+ {
+ line_anchor = q->line_ptr;
+ freeline (q);
+ q = line_anchor;
+ }
+ else
+ found = TRUE;
+ }
+ }
+
+ }
+ }
+
+ else
+ error (BAD_LINE, 0);
+
+ /* Erase symbols */
+ if (k == 0)
+ {
+ p = sym_anchor;
+ sym_anchor = NULL;
+ while (p != NULL)
+ {
+ p1 = p->sym_ptr;
+ freesym (p);
+ p = p1;
+ }
+ }
+
+} /* erasecmd */
+
+/************************************************************************
+*
+* ERROR - General error processor
+*
+* Procedure ERROR genertates error messages from a passed error code
+*
+************************************************************************/
+
+void
+error (int err_code, int err_stat)
+{
+ char errorstring[256];
+
+ err_flag = TRUE;
+ errorstring[0] = '\0';
+
+ /* Print pending text */
+ if (pndx > PBEG)
+ {
+ fputc ('\n', output);
+ pndx = PBEG;
+ }
+
+ switch (err_code)
+ {
+
+ case USER_STOP:
+ user_stop = FALSE;
+ strcpy (errorstring, "Stop");
+ break;
+
+ case FPE_STOP:
+ fpe_stop = FALSE;
+ strcpy (errorstring, "Floating point exception");
+ break;
+
+ case BAD_CMD:
+ strcpy (errorstring, "Bad command");
+ switch (err_stat)
+ {
+ case LIBRARY_CMD :
+ strcat (errorstring, " in Library");
+ break;
+ default: ;
+ }
+ strcat (errorstring, "\nType HELP for a list of commands");
+ break;
+
+ case BAD_LINE:
+ strcpy (errorstring, "Bad line number");
+ switch (err_stat)
+ {
+ case GO_TARGET:
+ strcat (errorstring, " in GOTO");
+ break;
+ case DO_TARGET:
+ strcat (errorstring, " in DO");
+ break;
+ default: ;
+ }
+ break;
+
+ case BAD_VAR:
+ strcpy (errorstring, "Bad variable");
+ break;
+
+ case BAD_EXPR:
+ strcpy (errorstring, "Bad expression");
+ switch (err_stat)
+ {
+ case FOR_EXPR :
+ strcat (errorstring, " in FOR/SET, missing '='");
+ break;
+ case IF_EXPR:
+ strcat (errorstring, " in IF");
+ break;
+ case TAB_EXPR:
+ strcat (errorstring, " in tab value");
+ break;
+ default: ;
+ }
+ break;
+
+ case UNDEF_FUNC:
+ strcpy (errorstring, "Undefined function");
+ break;
+
+ case BAD_FUNC:
+ strcpy (errorstring, "Bad function usage");
+ break;
+
+ case BAD_STRING:
+ strcpy (errorstring, "Bad text string");
+ break;
+
+ case BAD_NUM:
+ strcpy (errorstring, "Bad number");
+ break;
+
+ case MEM_OVERFLOW:
+ strcpy (errorstring, "Overflow - ");
+ switch (err_stat)
+ {
+ case LINE_OVERFLOW:
+ strcat (errorstring, "line buffer");
+ break;
+ case SYMBOL_OVERFLOW:
+ strcat (errorstring, "symbol table");
+ break;
+ case STACK_OVERFLOW:
+ strcat (errorstring, "stack");
+ break;
+ default: ;
+ }
+ break;
+
+ case PARSE_ERROR:
+ switch (err_stat)
+ {
+ /* Get the generated parser errors */
+#include "perrors.h"
+ default:
+ sprintf (errorstring, "Parse error = %d", err_stat);
+ }
+ break;
+
+ case SCAN_ERROR:
+ switch (err_stat)
+ {
+ case 4:
+ case 9:
+ strcpy (errorstring, "Bad exponent sign");
+ break;
+ case 7:
+ strcpy (errorstring, "Bad fraction");
+ break;
+ case 8:
+ strcpy (errorstring, "Exponent overflow");
+ break;
+ default:
+ sprintf (errorstring, "Scan error = %d", err_stat);
+ }
+ break;
+
+ case INTERP_ERROR:
+ switch (err_stat)
+ {
+ case ZERO_DIVIDE:
+ strcpy (errorstring, "Divide by zero");
+ break;
+ case NEG_SQRT:
+ strcpy (errorstring, "Negative SQRT");
+ break;
+ case NEG_LOG:
+ strcpy (errorstring, "Negative or zero LOG");
+ break;
+ default:
+ sprintf (errorstring, "Interp error = %d", err_stat);
+ }
+ break;
+
+ case MODIFY_ERROR:
+ strcpy (errorstring, "No match found");
+ break;
+
+ case FILE_ERROR:
+ break;
+
+ default:
+ strcpy (errorstring, "Undefined error");
+ }
+
+ fprintf (stderr, errorstring);
+
+ /* clean up */
+ cleaner();
+
+} /* error */
+
+/************************************************************************
+*
+* EXECLINE - Execute line
+*
+* Procedure EXEC_LINE processes source/command lines pointed to by
+* the PC.
+*
+************************************************************************/
+
+static void
+execline (void)
+{
+ do_stk_t *q;
+ for_stk_t *q1;
+ line_node_t *p;
+ tokval val;
+ int doit, next;
+
+#ifdef DEBUG_INPUT
+ printf ("execline: entered\n");
+#endif
+
+ do
+ {
+
+ do
+ {
+
+ /* Process command */
+ if (trace_flag)
+ {
+ if (isalpha (*pcp))
+ fprintf (stdout, "%c, ", upcase (*pcp));
+ }
+ switch (upcase (*pcp++))
+ {
+
+ case 'A' : askcmd(); break;
+ /*case 'B' : AVAILABLE break;*/
+ case 'C' : continuecmd(); break;
+ case 'D' : docmd(); break;
+ case 'E' : erasecmd(); break;
+ case 'F' : forcmd(); break;
+ case 'G' : gocmd(); break;
+ case 'H' : helpcmd(); break;
+ case 'I' : ifcmd(); break;
+ /*case 'J' : AVAILABLE break;*/
+ /*case 'K' : AVAILABLE break;*/
+ case 'L' : librarycmd(); break;
+ case 'M' : modifycmd(); break;
+ /*case 'N' : AVAILABLE break;*/
+ /*case 'O' : AVAILABLE break;*/
+ /*case 'P' : AVAILABLE break;*/
+ case 'Q' : quitcmd(); break;
+ case 'R' : returncmd(); break;
+ case 'S' : setcmd(); break;
+ case 'T' : typecmd(); break;
+ /*case 'U' : AVAILABLE break;*/
+ /*case 'V' : AVAILABLE break;*/
+ case 'W' : writecmd(); break;
+ /*case 'X' : AVAILABLE break;*/
+ /*case 'Y' : AVAILABLE break;*/
+ /*case 'Z' : AVAILABLE break;*/
+ case EOL : pcp--; break;
+ case ' ' :
+ case ';' : break;
+ default:
+
+ if (trace_flag)
+ {
+ pndx = PBEG;
+ pcp--;
+ printf ("\npc = %08x, pcp = %08x\n", pc, pcp);
+ printf ("grp = %s, stp = %s\n", pc->grp_num, pc->stp_num);
+ printf ("line = '%s'\n", pc->line_txt);
+ printf ("%c(%02x): ", *pcp, *pcp);
+ }
+ error (BAD_CMD, COMMAND);
+ }
+
+ /* Check for floating point exception */
+ if (fpe_stop)
+ error (FPE_STOP, 0);
+
+ /* Check for user abort */
+ if (user_stop)
+ error (USER_STOP, 0);
+
+ } while (*pcp && *pcp != EOL && !err_flag);
+
+ next = TRUE;
+
+ /* Check for loop in progress */
+ if (pc_top != NULL)
+ if (pc_top->pc_flags == FOR_FLG)
+ {
+ symboltable (for_top->for_index, &val, 0, TRUE);
+ val = val + for_top->for_inc;
+ symboltable (for_top->for_index, &val, 0, FALSE);
+ if (val <= for_top->for_limit)
+ {
+ next = FALSE;
+ pc = pc_top->old_pc;
+ pcp = pc_top->pc_index;
+ if (trace_flag)
+ {
+ fprintf (stdout, "\n-F%s.%s ", pc->grp_num, pc->stp_num);
+ }
+ }
+ else
+ {
+ pcpop();
+ q1 = for_top;
+ for_top = q1->for_ptr;
+ freefor (q1);
+ break;
+ }
+ }
+
+ /* Not a loop must be DO */
+ else
+ {
+ p = pc->line_ptr;
+ doit = FALSE;
+ if (p == NULL)
+ doit = TRUE;
+ else
+ {
+ if (strcmp (p->grp_num, do_top->do_grp))
+ doit = TRUE;
+ }
+ if (!do_top->do_flag)
+ doit = TRUE;
+ if (doit)
+ {
+ pc = pc_top->old_pc;
+ pcp = pc_top->pc_index;
+ if (trace_flag)
+ {
+ fprintf (stdout, "\n-D%s.%s ", pc->grp_num, pc->stp_num);
+ }
+ next = FALSE;
+ pcpop();
+ q = do_top;
+ do_top = q->do_ptr;
+ freedo (q);
+ if (do_top == NULL)
+ do_mode = FALSE;
+ }
+ }
+
+ if ((run_mode || do_mode) && next)
+ {
+ /* Point PC to next line */
+ p = pc->line_ptr;
+ if (p != NULL)
+ {
+ pc = p;
+ pcp = pc->line_txt;
+ if (trace_flag)
+ {
+ fprintf (stdout, "\nN%s.%s ", pc->grp_num, pc->stp_num);
+ }
+ }
+ else run_mode = FALSE;
+ }
+
+ } while (run_mode || pc_top != NULL);
+
+} /* execline */
+
+/************************************************************************
+*
+* EXPRESSION - Scan out expression
+*
+* Procedure EXPERSSION scans out expressions and calls the parser to
+* reduce the expression to a value.
+*
+************************************************************************/
+
+static tokval
+expression (void)
+{
+ char *bp;
+ char expr[LINE_LEN+1];
+
+ bp = expr;
+ while (*pcp && *pcp != EOL && *pcp != ',' && *pcp != ';' && *pcp != '=' &&
+ *pcp != '"' && *pcp != '%' && *pcp != '!')
+ {
+ if (*pcp != ' ')
+ *bp++ = *pcp;
+ pcp++;
+ }
+ *bp++ = EOL;
+ *bp = EOL;
+ if (trace_flag)
+ {
+ fprintf (stdout, "expr(%s) ", expr);
+ }
+
+ return (Parser (expr));
+
+} /* expression */
+
+/************************************************************************
+*
+* FINDLINE - Find line
+*
+* Procedure FINDLINE returns the address of the line addressed by the
+* line number in the buffer.
+*
+************************************************************************/
+
+static line_node_t *
+findline (void)
+{
+ line_node_t *l, *p;
+ int found;
+ char stp[TWOCHAR+1], grp[TWOCHAR+1];
+
+ p = NULL;
+
+ /* Get line group */
+ getgrp (grp);
+ if (*pcp == '.')
+ {
+ pcp++;
+
+ /* Get line step */
+ getstp (stp);
+ p = line_anchor;
+
+ /* See if going forward */
+ if (run_mode)
+ {
+ l = pc;
+ if (strcmp (l->grp_num, grp) <= 0 &&
+ (strcmp (l->grp_num, grp) == 0 && strcmp (l->stp_num, stp) <= 0))
+ p = l;
+ }
+
+ found = FALSE;
+ while (p != NULL && !found)
+ if (!strcmp (p->grp_num, grp) &&
+ !strcmp (p->stp_num, stp))
+ found = TRUE;
+ else
+ p = p->line_ptr;
+ }
+
+ return (p);
+
+} /* findline */
+
+/************************************************************************
+*
+* FMTNUM - Format numbers
+*
+* This routine format numbers for printing in either tokvaling or fixed
+* format.
+*
+************************************************************************/
+
+static void
+fmtnum (tokval val)
+{
+ int ival;
+ char format[30];
+
+ if (width > 0)
+ {
+ pndx += width;
+ if (digits > 0)
+ {
+ sprintf (format, "= %%%d.%df", width, digits);
+ fprintf (output, format, val);
+ }
+ else
+ {
+ sprintf (format, "= %%%dd", width);
+ ival = val;
+ fprintf (output, format, ival);
+ }
+ }
+
+ else
+ {
+ pndx += 13;
+ fprintf (output, "= %13.6e", val);
+ }
+
+} /* fmtnum */
+
+/************************************************************************
+*
+* FORCMD - FOR loop command
+*
+* Procedure FORCMD process the FOR statement. Syntax is:
+* F(OR) <NDX>=<START>[,<INC>],<END>;<STMT>
+*
+************************************************************************/
+
+static void
+forcmd (void)
+{
+ for_stk_t *p;
+ tokval v1, val;
+
+ /* Skip to index variable */
+ nextfield();
+
+ /* Error if function */
+ if (upcase (*pcp) == 'F')
+ {
+ error (BAD_FUNC, 0);
+ return;
+ }
+
+ if (free_for == NULL)
+ {
+ if ((p = (for_stk_t *)malloc (sizeof (for_stk_t))) == NULL)
+ {
+ error (MEM_OVERFLOW, STACK_OVERFLOW);
+ }
+ }
+ else
+ {
+ p = free_for;
+ free_for = p->for_ptr;
+ }
+
+ if (p != NULL)
+ {
+
+ memset ((void *)p, '\0', sizeof (for_stk_t));
+
+ /* Get index symbol */
+ getsym (p->for_index);
+
+ if (*pcp == ' ')
+ nextfield();
+
+ if (*pcp == '=')
+ {
+
+ /* get start expression */
+ pcp++;
+ v1 = val = expression();
+ symboltable (p->for_index, &val, 0, FALSE);
+
+ /* Get increment */
+ pcp++;
+ p->for_inc = expression();
+
+ /* If EOL then this is limit and inc is 1 */
+ if (*pcp == EOL || *pcp == ';')
+ {
+ p->for_limit = p->for_inc;
+ p->for_inc = 1.0;
+ if (*pcp == ';')
+ pcp++;
+ }
+
+ /* Get limit */
+ else
+ {
+ pcp++;
+ p->for_limit = expression();
+ }
+
+ if (!err_flag && (p->for_limit >= v1))
+ {
+ /* Set up FOR stack */
+ p->for_ptr = for_top;
+ for_top = p;
+ /* Set up PC stack */
+ pcpush();
+ pc_top->pc_flags = FOR_FLG;
+ /* Execute loop */
+ execline();
+ }
+
+ else
+ {
+ freefor (p);
+ while (*pcp && *pcp != EOL) pcp++;
+ }
+
+ }
+
+ /* bad loop expression */
+ else
+ {
+ error (BAD_EXPR, FOR_EXPR);
+ freefor (p);
+ }
+
+ }
+
+} /* forcmd */
+
+/************************************************************************
+*
+* GETGRP - Get line group
+*
+* Procedure GET_GRP gets the group number, 1 or 2 digits, from the
+* buffer and returns the value.
+*
+************************************************************************/
+
+static void
+getgrp (char grp[])
+{
+ char ch;
+
+ strcpy (grp, "00");
+ ch = *pcp++;
+ if (isdigit (ch))
+ {
+ if (isdigit (*pcp))
+ {
+ grp[0] = ch;
+ grp[1] = *pcp++;
+ }
+ else
+ grp[1] = ch;
+ }
+ else
+ error (BAD_LINE, 0);
+
+} /* getgrp */
+
+/************************************************************************
+*
+* GETSTP - Get line step
+*
+* Procedure GET_STP get the step number, 1 or 2 digits, from the buffer
+* and returns the value.
+*
+************************************************************************/
+
+static void
+getstp (char stp[])
+{
+ char ch;
+
+ strcpy (stp, "00");
+ ch = *pcp++;
+ if (isdigit (ch))
+ {
+ if (isdigit (*pcp))
+ {
+ stp[0] = ch;
+ stp[1] = *pcp++;
+ }
+ else
+ stp[0] = ch;
+ }
+ else
+ error (BAD_LINE, 0);
+
+} /* getstp */
+
+/************************************************************************
+*
+* GETSYM - Get symbol
+*
+* Procedure GET_SYM gets the symbol from the buffer.
+*
+************************************************************************/
+
+static void
+getsym (char sym[])
+{
+ int j;
+
+ strcpy (sym, " ");
+ j = 0;
+ while (*pcp && *pcp != EOL && isalnum (*pcp))
+ {
+ if (j < TWOCHAR)
+ sym[j++] = upcase (*pcp++);
+ else
+ pcp++;
+ }
+
+} /* getsym */
+
+/************************************************************************
+*
+* GOCMD - Go to command
+*
+* Procedure GOCMD process the go/goto statements. The syntax is:
+* G(O(TO)) (<LN>) if (the line number is absent) go to lowest
+* numbered line.
+*
+************************************************************************/
+
+static void
+gocmd (void)
+{
+
+ nextfield();
+ if (*pcp == '?')
+ {
+ trace_flag = TRUE;
+ nextfield();
+ }
+ if (line_anchor != NULL)
+ gotoit();
+
+} /* gocmd */
+
+/************************************************************************
+*
+* GOTOIT - GOTO line
+*
+* Procedure GOTOIT set the PC to the line number in the buffer.
+*
+************************************************************************/
+
+static void
+gotoit (void)
+{
+ line_node_t *p;
+
+ /* If line number present GOTOIT */
+ if (*pcp != EOL && *pcp != ';')
+ {
+ p = findline();
+
+ /* Set PC to target line */
+ if (p != NULL)
+ {
+ pc = p;
+ run_mode = TRUE;
+ }
+ else
+ error (BAD_LINE, GO_TARGET);
+ }
+
+ /* No line number use anchor */
+ else
+ {
+ pc = line_anchor;
+ if (pc != NULL)
+ {
+ run_mode = TRUE;
+ }
+ }
+
+ pcp = pc->line_txt;
+ if (trace_flag)
+ {
+ fprintf (stdout, "\nG%s.%s ", pc->grp_num, pc->stp_num);
+ }
+
+} /* gotoit */
+
+/************************************************************************
+*
+* HELPCMD - help command
+*
+* Procedure HELPCMD process the help command. Syntax:
+* H(ELP) [command]
+*
+************************************************************************/
+
+static void
+helpcmd (void)
+{
+ int all = FALSE;
+
+ /* Position to command, if any */
+ nextfield();
+
+ if (*pcp != EOL && *pcp != ';')
+ {
+ switch (upcase (*pcp++))
+ {
+
+ case '*' :
+ all = TRUE;
+ case 'A' :
+ printf (" A[SK] [\"PROMPT\",] <VAR>\n");
+ if (!all) break;
+ case 'C' :
+ printf (" C[ONTINUE]\n");
+ if (!all) break;
+ case 'D' :
+ printf (" D[O] ['?'] <GROUP>[.<STEP>]\n");
+ if (!all) break;
+ case 'E' :
+ printf (" E[RASE] [A[LL] | <GROUP>[.<STEP]]\n");
+ if (!all) break;
+ case 'F' :
+ printf (" F[OR] <VAR>=<START>[,<INC>],<END>; <COMMAND>\n");
+ if (!all) break;
+ case 'G' :
+ printf (" G[OTO] ['?'] [<LINE>]\n");
+ if (!all) break;
+ case 'H' :
+ printf (" H[ELP] [<COMMAND>]\n");
+ if (!all) break;
+ case 'I' :
+ printf (" I[F] (<EXPRESSION>) <LINE> [,<LINE>[,<LINE>]]\n");
+ if (!all) break;
+ case 'L' :
+ printf (" L[IBRARY] C[ALL] <FILENAME>\n");
+#if defined(BSDDIR) || defined(SYSVDIR)
+ printf (" L[IBRARY] L[IST] [<PATHNAME>]\n");
+#endif
+ printf (" L[IBRARY] P[RINT] <FILENAME>\n");
+ printf (" L[IBRARY] S[AVE] <FILENAME>\n");
+#if defined(BSDDIR) || defined(SYSVDIR)
+ printf (" L[IBRARY] W[ORK] <DIRNAME>\n");
+#endif
+ if (!all) break;
+ case 'M' :
+ printf (" M[ODIFY] <LINE> /OLDPATTERN/NEWPATTERN/\n");
+ if (!all) break;
+ case 'Q' :
+ printf (" Q[UIT]\n");
+ if (!all) break;
+ case 'R' :
+ printf (" R[ETURN]\n");
+ if (!all) break;
+ case 'S' :
+ printf (" S[ET] <VAR> = <EXPRESSION>\n");
+ if (!all) break;
+ case 'T' :
+ printf (" T[YPE] [\"TEXT\",] <VAR> | <EXPRESSION>\n");
+ if (!all) break;
+ case 'W' :
+ printf (" W[RITE] [A[LL] | <GROUP>[.<STEP]]\n");
+ if (!all) break;
+ case ' ' :
+ break;
+ default:
+ error (BAD_CMD, COMMAND);
+ }
+ nextfield();
+ }
+ else
+ {
+ printf ("Commands:\n");
+ printf (" ASK CONTINUE DO ERASE FOR GOTO\n");
+ printf (" HELP IF LIBRARY MODIFY QUIT RETURN\n");
+ printf (" SET TYPE WRITE\n");
+ }
+
+} /* helpcmd */
+
+/************************************************************************
+*
+* IFCMD - if command
+*
+* Procedure IFCMD process the if command. Syntax:
+* I(F) (<EXPR>) <LN>[,<LN>[,<LN>]];
+*
+************************************************************************/
+
+static void
+ifcmd (void)
+{
+ char *bp;
+ tokval val;
+ int k, j;
+
+ /* Position to expression */
+ nextfield();
+
+ /* Scan out expression */
+ bp = tbuf;
+ if (*pcp == '(')
+ {
+ while (*pcp != EOL && *pcp != ',' && *pcp != ';') *bp++ = *pcp++;
+ do
+ {
+ pcp--;
+ bp--;
+ } while (*(bp-1) != ')');
+ *bp++ = EOL;
+ *bp = EOL;
+
+ /* Get value of expression */
+ val = Parser (tbuf);
+ if (val == 0.0)
+ j = 1;
+ else if (val > 0.0)
+ j = 2;
+ else
+ j = 0;
+
+ /* Go to target line number */
+ k = 0;
+ while (k < j)
+ {
+ while (*pcp != EOL && *pcp != ',' && *pcp != ';') pcp++;
+ if (*pcp == ',') pcp++;
+ k++;
+ }
+ while (*pcp == ' ') pcp++;
+ if (*pcp != EOL && *pcp != ';')
+ gotoit();
+
+ }
+
+ else
+ error (BAD_EXPR, IF_EXPR);
+
+} /* ifcmd */
+
+/************************************************************************
+*
+* INSERTLINE - Insert text line
+*
+* Procedure INSERT_LINE takes a source line and links it into the line
+* buffer in group/step order. if the line currently exists it text is
+* replaced with the new text.
+*
+************************************************************************/
+
+static void
+insertline (void)
+{
+ line_node_t *p, *next, *back;
+ char *bp;
+ int found;
+ char olinnum[6], nlinnum[6];
+
+ if (free_line == NULL)
+ {
+ if ((p = (line_node_t *)malloc (sizeof (line_node_t))) == NULL)
+ {
+ error (MEM_OVERFLOW, LINE_OVERFLOW);
+ }
+ }
+ else
+ {
+ p = free_line;
+ free_line = p->line_ptr;
+ }
+
+ if (p != NULL)
+ {
+ memset ((void *)p, '\0', sizeof (line_node_t));
+
+ p->line_ptr = NULL;
+ /* Get line group number */
+ getgrp (p->grp_num);
+ if (!err_flag)
+ if (*pcp == '.')
+ {
+ pcp++;
+ /* Get line step number */
+ getstp (p->stp_num);
+ if (!err_flag)
+ {
+ while (*pcp == ' ') pcp++;
+ bp = p->line_txt;
+ while (*pcp)
+ {
+ if (*pcp != '\n' && *pcp != '\r')
+ *bp++ = *pcp;
+ pcp++;
+ }
+ *bp = EOL;
+#ifdef DEBUG_FILE
+ printf ("p(%d) = '%s'\n", strlen(p->line_txt), p->line_txt);
+#endif
+ back = line_anchor;
+ next = line_anchor;
+
+ /* If no lines then link at top */
+ if (line_anchor == NULL)
+ {
+#ifdef DEBUG_FILE
+ printf ("HEAD: p = %p\n", p);
+ HEXDUMP (stdout, (char *)p, sizeof (line_node_t));
+#endif
+ line_anchor = p;
+ }
+
+ /* Search for place to insert */
+ else
+ {
+ found = FALSE;
+ sprintf (olinnum, "%s%s", p->grp_num, p->stp_num);
+#ifdef DEBUG_FILE
+ printf ("olinnum = '%s'\n", olinnum);
+#endif
+ while (next != NULL && !found)
+ {
+ sprintf (nlinnum, "%s%s", next->grp_num, next->stp_num);
+#ifdef DEBUG_FILE
+ printf ("nlinnum = '%s'\n", nlinnum);
+#endif
+ if (strcmp (nlinnum, olinnum) < 0)
+ {
+ back = next;
+ next = next->line_ptr;
+ }
+ else
+ found = TRUE;
+ }
+
+ /* Link at end of list */
+ if (next == NULL)
+ {
+#ifdef DEBUG_FILE
+ printf ("END: p = %p\n", p);
+ HEXDUMP (stdout, (char *)p, sizeof (line_node_t));
+#endif
+ back->line_ptr = p;
+ }
+
+ /* Insert new line */
+ else if (strcmp (nlinnum, olinnum))
+ {
+#ifdef DEBUG_FILE
+ printf ("INSERT: p = %p\n", p);
+ HEXDUMP (stdout, (char *)p, sizeof (line_node_t));
+#endif
+ /* Link in at top of list */
+ if (next == line_anchor)
+ {
+ line_anchor = p;
+ p->line_ptr = next;
+ }
+ /* Link into middle */
+ else
+ {
+ back->line_ptr = p;
+ p->line_ptr = next;
+ }
+ }
+
+ /* Replace old with new */
+ else
+ {
+ pcp = p->line_txt;
+ while (*pcp && *pcp != ' ') pcp++;
+ if (*pcp != EOL)
+ {
+ strcpy (next->line_txt, p->line_txt);
+ }
+ /* Null input, delete */
+ else
+ {
+ back->line_ptr = next->line_ptr;
+ freeline (next);
+ }
+ freeline (p);
+ }
+
+ }
+ }
+ else
+ {
+ error (BAD_LINE, 0);
+ freeline (p);
+ }
+ }
+ else
+ {
+ error (BAD_LINE, 0);
+ freeline (p);
+ }
+
+ }
+
+} /* insertline */
+
+/************************************************************************
+*
+* LIBRARYCMD - Provide library services
+*
+* Procedure LIBRARY processes the librarian functions. Syntax is:
+* L(IBRARY) C(ALL) <PATHNAME> reads program from file
+* L(IBRARY) L(IST) [<PATHNAME>] list programs
+* L(IBRARY) P(RINT) <PATHNAME> sends type/write output to file
+* L(IBRARY) S(AVE) <PATHNAME> saves program in file
+* L(IBRARY) W(ORK) <PATHNAME> change working directory
+*
+************************************************************************/
+
+static void
+librarycmd (void)
+{
+#if defined(BSDDIR) || defined(SYSVDIR)
+ DIR *dir;
+#endif
+ line_node_t *spc, *p, tp;
+ char ch, *bp, *mode;
+ int done, k;
+ char fname[LINE_LEN+1];
+
+ /* Position to function */
+ nextfield();
+
+ /* Get function (C,S,P) */
+ ch = *pcp;
+ nextfield();
+
+ /* Scan off pathname */
+ bp = tbuf;
+ while (*pcp && *pcp != EOL && *pcp != ';' && *pcp != ' ') *bp++ = *pcp++;
+ *bp = EOL;
+ fname[0] = EOL;
+
+#ifdef DIGNUS
+ strcpy (fname, "//DSN:");
+#endif
+
+ switch (upcase (ch))
+ {
+
+ case 'C' : /* Call (load) program */
+ if (tbuf[0] != EOL)
+ {
+#if defined(BSDDIR) || defined(SYSVDIR)
+ if (tbuf[0] != '/')
+ {
+ sprintf (fname, "%s/", wd);
+ }
+#endif
+ strcat (fname, tbuf);
+ }
+ else
+ {
+ fprintf (stderr, "Filename is required");
+ error (FILE_ERROR, 0);
+ return;
+ }
+#if defined(OS390)
+ for (bp = fname; *bp; bp++)
+ *bp = upcase (*bp);
+#else
+ /* Append extension */
+
+ if ((bp = (char *)strrchr (tbuf, '.')) == NULL)
+ {
+ strcat (fname, FOCAL_EXT);
+ }
+#endif
+
+ if ((progfile = fopen (fname, "r")) != NULL)
+ {
+ spc = pc;
+ mode = pcp;
+ done = FALSE;
+ while (!done)
+ {
+
+ if (fgets (tbuf, sizeof (tbuf), progfile) != NULL)
+ {
+ *((char *)(strchr (tbuf, '\n'))) = EOL;
+ k = strlen (tbuf);
+#ifdef DEBUG_FILE
+ printf ("tbuf(%d) = '%s'\n", k, tbuf);
+#endif
+ memset ((void *)&tp, '\0', sizeof(line_node_t));
+ pc = &tp;
+ pcp = pc->line_txt;
+ strcpy (pcp, tbuf);
+ if (isdigit (*pcp))
+ insertline();
+ }
+ else
+ done = TRUE;
+ }
+ pcp = mode;
+ pc = spc;
+ fclose (progfile);
+ }
+ else
+ {
+ fprintf (stderr, "Can't open for read : %s", fname);
+#if defined(STRERROR)
+ fprintf (stderr, " : %s", strerror (errno));
+#else
+ perror (" ");
+#endif
+ error (FILE_ERROR, errno);
+ }
+ break;
+
+ case 'L' : /* L(ist) files */
+#if defined(BSDDIR) || defined(SYSVDIR)
+ if (tbuf[0] == EOL)
+ {
+ strcpy (tbuf, wd);
+ }
+ if ((dir = opendir (tbuf)) != NULL)
+ {
+ struct stat stbuf;
+#if defined(BSDDIR)
+ struct direct *myent;
+#endif
+#if defined(SYSVDIR)
+ struct dirent *myent;
+#endif
+ while ((myent = readdir (dir)) != NULL)
+ {
+ char *bp;
+
+ if ((bp = strrchr (myent->d_name, '.')) != NULL)
+ {
+ if (!strcmp (bp, FOCAL_EXT))
+ {
+
+ sprintf (fname, "%s/%s", tbuf, myent->d_name);
+ if (stat (fname, &stbuf) == 0)
+ {
+ printf ("%6ld %s\n", stbuf.st_size, myent->d_name);
+ }
+ else
+ {
+ fprintf (stderr, "Can't stat file : %s", myent->d_name);
+#if defined(STRERROR)
+ fprintf (stderr, " : %s", strerror (errno));
+#else
+ perror (" ");
+#endif
+ error (FILE_ERROR, errno);
+ }
+ }
+ }
+ }
+ closedir (dir);
+ }
+ else
+ {
+ fprintf (stderr, "Can't open directory : %s", tbuf);
+#if defined(STRERROR)
+ fprintf (stderr, " : %s", strerror (errno));
+#else
+ perror (" ");
+#endif
+ error (FILE_ERROR, errno);
+ }
+#else
+ fprintf (stderr, "List not supported for this OS");
+ error (FILE_ERROR, 0);
+#endif
+ break;
+
+ case 'P' : /* Print to new file */
+ if (pndx > PBEG)
+ {
+ fputs ("\n", output);
+ pndx = PBEG;
+ }
+
+ if (output != stdout)
+ fclose (output);
+
+ if (!strcmp (tbuf, "TTY") ||
+ !strcmp (tbuf, "tty"))
+ {
+ output = stdout;
+ }
+
+ else
+ {
+ if (tbuf[0] != EOL)
+ {
+#if defined(BSDDIR) || defined(SYSVDIR)
+ if (tbuf[0] != '/')
+ {
+ sprintf (fname, "%s/", wd);
+ }
+#endif
+ strcat (fname, tbuf);
+ }
+ else
+ {
+ fprintf (stderr, "Filename is required");
+ error (FILE_ERROR, 0);
+ return;
+ }
+#if defined(OS390)
+ for (bp = fname; *bp; bp++)
+ *bp = upcase(*bp);
+#else
+ /* Append extension */
+
+ if ((bp = (char *)strrchr (tbuf, '.')) == NULL)
+ {
+ strcat (fname, FOCAL_LST);
+ }
+#endif
+
+ if ((output = fopen (fname, "w")) == NULL)
+ {
+ output = stdout;
+ fprintf (stderr, "Can't open for write : %s", fname);
+#if defined(STRERROR)
+ fprintf (stderr, " : %s", strerror (errno));
+#else
+ perror (" ");
+#endif
+ error (FILE_ERROR, errno);
+ }
+ }
+ break;
+
+ case 'S' : /* Save program */
+ if (tbuf[0] != EOL)
+ {
+#if defined(BSDDIR) || defined(SYSVDIR)
+ if (tbuf[0] != '/')
+ {
+ sprintf (fname, "%s/", wd);
+ }
+#endif
+ strcat (fname, tbuf);
+ }
+ else
+ {
+ fprintf (stderr, "Filename is required");
+ error (FILE_ERROR, 0);
+ return;
+ }
+#if defined(OS390)
+ for (bp = fname; *bp; bp++)
+ *bp = upcase(*bp);
+#else
+ /* Append extension */
+
+ if ((bp = (char *)strrchr (tbuf, '.')) == NULL)
+ {
+ strcat (fname, FOCAL_EXT);
+ }
+#endif
+
+ if ((progfile = fopen (fname, "w")) != NULL)
+ {
+ p = line_anchor;
+ while (p != NULL)
+ {
+ fprintf (progfile, "%s.%s %s\n",
+ p->grp_num, p->stp_num, p->line_txt);
+ p = p->line_ptr;
+ }
+ fclose (progfile);
+ }
+ else
+ {
+ fprintf (stderr, "Can't open for write : %s", fname);
+#if defined(STRERROR)
+ fprintf (stderr, " : %s", strerror (errno));
+#else
+ perror (" ");
+#endif
+ error (FILE_ERROR, errno);
+ }
+ break;
+
+ case 'W': /* Change Working directory */
+#if defined(BSDDIR) || defined(SYSVDIR)
+ if (tbuf[0] != EOL)
+ {
+ if ((dir = opendir (tbuf)) != NULL)
+ {
+ closedir (dir);
+ strcpy (wd, tbuf);
+ }
+ else
+ {
+ fprintf (stderr, "Can't open directory : %s", tbuf);
+#if defined(STRERROR)
+ fprintf (stderr, " : %s", strerror (errno));
+#else
+ perror (" ");
+#endif
+ error (FILE_ERROR, errno);
+ }
+ }
+ else
+ {
+ fprintf (stderr, "Pathname is required");
+ error (FILE_ERROR, 0);
+ }
+#else
+ fprintf (stderr, "Working directory not supported for this OS");
+ error (FILE_ERROR, 0);
+#endif
+ break;
+
+ default:
+ error (BAD_CMD, LIBRARY_CMD);
+
+ }
+
+} /* librarycmd */
+
+/************************************************************************
+*
+* MODIFYCMD - Modify source line
+*
+* Procedure MODIFY fixes up source lines and has the following
+* syntax:
+* M(ODIFY) GG.SS /OLD/NEW/
+*
+************************************************************************/
+
+static void
+modifycmd (void)
+{
+ line_node_t *l;
+ int start_pos, match_pos;
+ int found, done;
+ int i, j, k, disp;
+ int new_len, old_len;
+ char delim;
+
+ nextfield();
+ l = findline();
+ if (l != NULL)
+ {
+ nextfield();
+ if (*pcp != EOL)
+ {
+ delim = *pcp++;
+ start_pos = (int)(pcp - pc->line_txt);
+ j = 0;
+ done = FALSE;
+ while (!done)
+ {
+ k = start_pos;
+ while (l->line_txt[j] != pc->line_txt[k] &&
+ l->line_txt[j] != EOL) j++;
+ match_pos = j;
+ if (l->line_txt[j] != EOL)
+ {
+ found = FALSE;
+ do
+ {
+ if (l->line_txt[j] == pc->line_txt[k])
+ {
+ j++;
+ k++;
+ if (pc->line_txt[k] == delim)
+ found = TRUE;
+ }
+ else
+ break;
+ } while (!found && l->line_txt[j] != EOL);
+ if (found)
+ {
+ k++;
+ i = k;
+ pcp = &pc->line_txt[k];
+ while (*pcp && *pcp != delim && *pcp != EOL)
+ {
+ k++;
+ pcp++;
+ }
+ if (*pcp == delim) pcp++;
+ new_len = k - i;
+ old_len = j - match_pos;
+ /* Contract line */
+ if (old_len > new_len)
+ {
+ disp = old_len - new_len;
+ for (k = j; l->line_txt[k] != EOL; k++)
+ l->line_txt[k-disp] = l->line_txt[k];
+ l->line_txt[k-disp] = EOL;
+ }
+ /* Expand line */
+ else if (old_len < new_len)
+ {
+ disp = new_len - old_len;
+ for (k = strlen (l->line_txt)+disp; k > j; k--)
+ l->line_txt[k] = l->line_txt[k-disp];
+ }
+ /* Copy in new text */
+ for (j = 0; j < new_len; j++)
+ l->line_txt[match_pos++] = pc->line_txt[i++];
+ done = TRUE;
+ }
+ else
+ j = match_pos + 1;
+ }
+ else
+ {
+ done = TRUE;
+ error (MODIFY_ERROR, 0);
+ }
+ } /* while */
+ }
+ }
+ else
+ error (BAD_LINE, 0);
+
+} /* modifycmd */
+
+/************************************************************************
+*
+* NEXTFIELD - Skip to next field
+*
+* Procedure NEXT_FIELD moves the pointer forward in the buffer
+* to the next non_blank field, end of command (;) or end of line.
+*
+************************************************************************/
+
+static void
+nextfield (void)
+{
+
+ while (*pcp && *pcp != EOL && *pcp != ' ' && *pcp != ';') pcp++;
+ while (*pcp == ' ') pcp++;
+
+} /* nextfield */
+
+/************************************************************************
+*
+* PCPOP - Pops the PC context
+*
+* This routine pops the context from the PC stack.
+*
+************************************************************************/
+
+static void
+pcpop (void)
+{
+ pc_stk_t *p;
+
+ p = pc_top;
+ pc_top = p->pc_ptr;
+ p->pc_ptr = free_pc;
+ free_pc = p;
+
+} /* pcpop */
+
+/************************************************************************
+*
+* PCPUSH - Push PC context
+*
+* This routine pushes the program context on the PC stack.
+*
+************************************************************************/
+
+static void
+pcpush (void)
+{
+ pc_stk_t *p;
+
+ if (free_pc == NULL)
+ {
+ if ((p = (pc_stk_t *)malloc (sizeof (pc_stk_t))) == NULL)
+ {
+ error (MEM_OVERFLOW, STACK_OVERFLOW);
+ }
+ }
+ else
+ {
+ p = free_pc;
+ free_pc = p->pc_ptr;
+ }
+
+ if (p != NULL)
+ {
+ memset ((void *)p, '\0', sizeof (pc_stk_t));
+
+ p->pc_index = pcp;
+ p->old_pc = pc;
+ p->pc_ptr = pc_top;
+ pc_top = p;
+ }
+
+} /* pcpush */
+
+/************************************************************************
+*
+* QUIT - Quit command
+*
+* This routine processes the quit command.
+*
+************************************************************************/
+
+static void
+quitcmd (void)
+{
+ do_stk_t *p;
+ for_stk_t *q;
+
+ nextfield();
+ if (!(run_mode || do_mode))
+ quit_flag = TRUE;
+ run_mode = FALSE;
+ do_mode = FALSE;
+
+ while (pc_top != NULL)
+ pcpop();
+
+ while (do_top != NULL)
+ {
+ p = do_top;
+ do_top = p->do_ptr;
+ freedo (p);
+ }
+
+ while (for_top != NULL)
+ {
+ q = for_top;
+ for_top = q->for_ptr;
+ freefor (q);
+ }
+
+} /* quitcmd */
+
+/************************************************************************
+*
+* RETURNCMD - Return command
+*
+* This routine processes the return command.
+*
+************************************************************************/
+
+static void
+returncmd (void)
+{
+ do_stk_t *p;
+ for_stk_t *q;
+
+ nextfield();
+ if (do_top != NULL)
+ {
+ while (pc_top->pc_flags != DO_FLG)
+ {
+ pcpop();
+ q = for_top;
+ for_top = q->for_ptr;
+ freefor (q);
+ }
+ pc = pc_top->old_pc;
+ pcp = pc_top->pc_index;
+ if (trace_flag)
+ {
+ fprintf (stdout, "\nR%s.%s ", pc->grp_num, pc->stp_num);
+ }
+ pcpop();
+ p = do_top;
+ do_top = p->do_ptr;
+ freedo (p);
+ if (do_top == NULL)
+ do_mode = FALSE;
+ }
+
+} /* returncmd */
+
+/************************************************************************
+*
+* SETCMD - Set command
+*
+* This routine processes the set command. Syntax:
+* S(ET) <VAR> = <EXPR>
+*
+************************************************************************/
+
+static void
+setcmd (void)
+{
+ tokval val;
+ int ndx;
+ char sym[TWOCHAR+1];
+
+ nextfield();
+
+ /* Error if function */
+ if (upcase (*pcp) == 'F')
+ {
+ error (BAD_FUNC, 0);
+ return;
+ }
+
+ getsym (sym);
+ if (*pcp == ' ')
+ nextfield();
+
+ ndx = 0;
+ if (*pcp == '(' || *pcp == '<' || *pcp == '[' || *pcp == '{')
+ {
+ ndx = expression();
+ }
+
+ if (!err_flag)
+ {
+ if (*pcp == ' ')
+ nextfield();
+ if (*pcp == '=')
+ {
+ pcp++;
+ val = expression();
+ if (!err_flag)
+ symboltable (sym, &val, ndx, FALSE);
+ }
+ else
+ error (BAD_EXPR, FOR_EXPR);
+ }
+
+} /* setcmd */
+
+/************************************************************************
+*
+* SYMBOLTABLE - Process symbol table
+*
+* This routine stores and/or retrieves data from the symbol table.
+* if the symbol is not found it is created with an initial value of
+* zero.
+*
+************************************************************************/
+
+void
+symboltable (char *sym, tokval *val, int ndx, int flg)
+{
+ sym_node_t *p, *next;
+ int j, found;
+ char lsym[TWOCHAR+1];
+
+#ifdef DEBUG_SYMTAB
+ printf ("symboltable: sym = '%s', ndx = %d, flg = %s\n",
+ sym, ndx, flg ? "TRUE" : "FALSE");
+#endif
+ strcpy (lsym, " ");
+ for (j = 0; j < strlen (sym); j++)
+ if (j < TWOCHAR)
+ lsym[j] = sym[j];
+
+ if (free_sym == NULL)
+ {
+ if ((p = (sym_node_t *)malloc (sizeof (sym_node_t))) == NULL)
+ {
+ error (MEM_OVERFLOW, SYMBOL_OVERFLOW);
+ }
+ }
+ else
+ {
+ p = free_sym;
+ free_sym = p->sym_ptr;
+ }
+
+ if (p != NULL)
+ {
+ memset ((void *)p, '\0', sizeof (sym_node_t));
+
+ /* Initialize new node */
+ p->sym_ptr = NULL;
+ strcpy (p->symbol, lsym);
+ p->sym_index = ndx;
+ p->sym_value = *val;
+ next = sym_anchor;
+
+ /* If list empty add at head */
+ if (sym_anchor == NULL)
+ sym_anchor = p;
+
+ else
+ {
+
+ found = FALSE;
+ while (next != NULL && !found)
+ if (!strcmp (next->symbol, lsym) &&
+ (next->sym_index == ndx))
+ found = TRUE;
+ else
+ next = next->sym_ptr;
+
+ /* Symbol not found */
+ if (next == NULL)
+ {
+ /* Link new sym at head */
+ p->sym_ptr = sym_anchor;
+ sym_anchor = p;
+ }
+
+ /* Symbol is found */
+ else
+ {
+ freesym (p);
+ /* If flag is true */
+ if (flg)
+ {
+ /* Return current value */
+ *val = next->sym_value;
+ }
+ else
+ {
+ /* Set new value */
+ next->sym_value = *val;
+ }
+ }
+ }
+ }
+
+} /* symboltable */
+
+/************************************************************************
+*
+* TYPECMD - Type command
+*
+* this procedure processes the type command. The recognized forms are
+* as follows:
+* T(YPE) <VAR> type a variable
+* T(YPE) <EXPR> type an expression
+* T(YPE) "TEXT" type a text string
+*
+************************************************************************/
+
+static void
+typecmd (void)
+{
+ sym_node_t *p;
+ tokval val;
+ int k, j;
+ char delim;
+ char row[TWOCHAR+1], col[TWOCHAR+1];
+
+ nextfield();
+ do
+ {
+
+ /* Buffer overflow print line */
+ if (pndx >= PLEN)
+ {
+ fputc ('\n', output);
+ pndx = PBEG;
+ }
+
+ switch (*pcp)
+ {
+
+ case '"' : /* Start of text string */
+ case '\'' :
+ if (trace_flag)
+ {
+ fputc (*pcp, output);
+ }
+ delim = *pcp++;
+ while (*pcp && *pcp != EOL && *pcp != delim)
+ {
+ fputc (*pcp++, output);
+ pndx++;
+ }
+ if (*pcp == EOL)
+ error (BAD_STRING, 0);
+ else
+ pcp++;
+ if (trace_flag)
+ {
+ fputc (delim, output);
+ }
+ break;
+
+ case '!' : /* Carriage return/line feed */
+ pcp++;
+ fputc ('\n', output);
+ pndx = PBEG;
+ break;
+
+ case '#' : /* Carriage return */
+ pcp++;
+ fputc ('\r', output);
+ pndx = PBEG;
+ break;
+
+ case '&' : /* Top of form */
+ pcp++;
+ fputc ('\f', output);
+ pndx = PBEG;
+ break;
+
+ case '$' : /* Print symbol table */
+ pcp++;
+ if (pndx > PBEG)
+ {
+ fputc ('\n', output);
+ pndx = PBEG;
+ }
+
+ p = sym_anchor;
+ while (p != NULL)
+ {
+ if (user_stop)
+ {
+ user_stop = FALSE;
+ return;
+ }
+ fprintf (output, "%s(%d) ", p->symbol, p->sym_index);
+ fmtnum (p->sym_value);
+ fputc ('\n', output);
+ p = p->sym_ptr;
+ }
+ break;
+
+ case '%' : /* Change numeric format */
+ pcp++;
+ width = 0;
+ digits = 0;
+ if (isdigit (*pcp))
+ {
+ getgrp (tbuf);
+ width = Parser (tbuf);
+ if (*pcp == '.')
+ {
+ pcp++;
+ getgrp (tbuf);
+ digits = Parser (tbuf);
+ }
+ }
+ break;
+
+ case ':' : /* TAB */
+ pcp++;
+ k = expression() + PBEG;
+ if (k > pndx)
+ for (j = pndx; j < k; j++)
+ fputc (' ', output);
+ pndx = k;
+ break;
+
+ case '@' : /* Position on the screen */
+ pcp++;
+ strcpy (row, "01");
+ strcpy (col, "01");
+
+ if (upcase (*pcp) == 'E')
+ {
+ pcp++;
+#if defined(ANSICRT)
+ clearscreen();
+#endif
+ }
+
+ if (isdigit (*pcp))
+ {
+ getgrp (row);
+ if (*pcp == '.')
+ {
+ pcp++;
+ getgrp (col);
+ }
+#if defined(ANSICRT)
+ screenposition (row, col);
+#endif
+ }
+
+ if (upcase (*pcp) == 'C')
+ {
+ pcp++;
+#if defined(ANSICRT)
+ clearline();
+#endif
+ }
+ break;
+
+ case ' ' :
+ case ',' :
+ pcp++;
+ break;
+
+ default : /* print value of expression */
+ val = expression();
+ if (!err_flag)
+ fmtnum (val);
+
+ } /* of switch */
+
+ } while (*pcp && *pcp != EOL && *pcp != ';' && !err_flag);
+
+#if defined(OS390) || defined(OS2)
+ fflush (output);
+#endif
+
+} /* typecmd */
+
+/************************************************************************
+*
+* WRITECMD - Write lines command
+*
+* This procedure processes the write command. The recognized forms are
+* as follows:
+* W(RITE) [A(LL)] write out entire buffer
+* W(RITE) GRP write out a group of lines
+* W(RITE) GRP.STP write out a single line
+*
+************************************************************************/
+
+static void
+writecmd (void)
+{
+ line_node_t *p, *back;
+ int found;
+ char stp[TWOCHAR+1], grp[TWOCHAR+1];
+
+ nextfield();
+ if (pndx > PBEG)
+ {
+ fputc ('\n', output);
+ pndx = PBEG;
+ }
+
+ /* List entire program */
+ if (upcase (*pcp) == 'A' || *pcp == EOL || *pcp == ';')
+ {
+ nextfield();
+ p = line_anchor;
+ back = line_anchor;
+
+ while (p != NULL)
+ {
+ if (user_stop)
+ {
+ user_stop = FALSE;
+ return;
+ }
+#ifdef DEBUG_FILE
+ printf ("p = %p\n", p);
+ HEXDUMP (output, (char *)p, sizeof (line_node_t));
+#endif
+ fprintf (output, "%s.%s %s\n", p->grp_num, p->stp_num, p->line_txt);
+ back = p;
+ p = p->line_ptr;
+ if (p != NULL)
+ if (strcmp (back->grp_num, p->grp_num))
+ fputc ('\n', output);
+ }
+
+ }
+
+ /* List a group of lines */
+ else if (isdigit (*pcp))
+ {
+ getgrp (grp);
+ p = line_anchor;
+ found = FALSE;
+
+ while (p != NULL && !found)
+ if (!strcmp (p->grp_num, grp))
+ found = TRUE;
+ else
+ p = p->line_ptr;
+
+ if (p != NULL)
+ {
+ /* list one line */
+ if (*pcp == '.')
+ {
+ pcp++;
+ getstp (stp);
+ if (!err_flag)
+ {
+ found = FALSE;
+ while (p != NULL && !found)
+ if (!strcmp (p->grp_num, grp) &&
+ !strcmp (p->stp_num, stp))
+ found = TRUE;
+ else
+ p = p->line_ptr;
+ }
+ if (p != NULL)
+ fprintf (output, "%s.%s %s\n",
+ p->grp_num, p->stp_num, p->line_txt);
+ }
+
+ /* Its a group */
+ else
+ {
+ found = FALSE;
+ while (p != NULL && !found)
+ if (!strcmp (p->grp_num, grp))
+ {
+ fprintf (output, "%s.%s %s\n",
+ p->grp_num, p->stp_num, p->line_txt);
+ if (user_stop)
+ {
+ user_stop = FALSE;
+ return;
+ }
+ p = p->line_ptr;
+ }
+ else
+ found = TRUE;
+ }
+ }
+ }
+
+ else ; /* Invalid write request */
+
+} /* writecmd */
+
+/***********************************************************************
+* fpeint - floating point exception
+***********************************************************************/
+
+void
+fpeint (int sig)
+{
+ fpe_stop = TRUE;
+ signal (SIGFPE, fpeint);
+}
+
+/***********************************************************************
+* userint - user keyboard interrupt
+***********************************************************************/
+
+void
+userint (int sig)
+{
+ user_stop = TRUE;
+ signal (SIGINT, userint);
+}
+
+/**********************************************************************
+*
+* Main driver
+*
+**********************************************************************/
+
+int
+main (int argc, char *argv[])
+{
+
+
+ /* Index into print buffer */
+ output = stdout;
+ input = stdin;
+ pndx = PBEG;
+
+ /* Set default width */
+ width = 10;
+
+ /* Set default significance */
+ digits = 4;
+
+ /* Seed random number generator */
+ time (&seed);
+ srand (seed);
+
+ /* Set list pointers to NULL */
+ line_anchor = NULL;
+ sym_anchor = NULL;
+ for_top = NULL;
+ pc_top = NULL;
+ do_top = NULL;
+ free_line = NULL;
+ free_sym = NULL;
+ free_for = NULL;
+ free_pc = NULL;
+ free_do = NULL;
+
+ /* Set initial flags */
+ quit_flag = FALSE;
+ user_stop = FALSE;
+ fpe_stop = FALSE;
+ run_mode = FALSE;
+ do_mode = FALSE;
+
+ /* Allocate keyboard buffer */
+ buffer = (line_node_t *)malloc (sizeof (line_node_t));
+ memset ((void *)buffer, '\0', sizeof (line_node_t));
+
+ /* Initialize keyboard event */
+ signal (SIGINT, userint);
+
+ /* Initialize Floating point exception */
+ signal (SIGFPE, fpeint);
+
+ /* Set the working directory */
+ strcpy (wd, ".");
+
+ /* If an arg, then execute it */
+ if (argc == 2)
+ {
+ pc = buffer;
+ err_flag = FALSE;
+ trace_flag = FALSE;
+ pndx = PBEG;
+ pcp = pc->line_txt;
+
+ sprintf (pc->line_txt, "L C %s;G%c", argv[1], EOL);
+ execline();
+ return (NORMAL);
+ }
+
+ /* Print the banner */
+ printf ("FOCAL-%s execution begins\n", VERSION, stdout);
+
+ /* Process until quit command or EOF */
+ while (!quit_flag)
+ {
+ pc = buffer;
+ err_flag = FALSE;
+ trace_flag = FALSE;
+ pndx = PBEG;
+
+ /* Prompt user for input */
+ fputc ('*', stdout);
+#if defined(OS390) || defined(OS2)
+ fputc ('\n', stdout);
+ fflush (stdout);
+#endif
+
+ if ((pcp = fgets (pc->line_txt, LINE_LEN, stdin)) != NULL)
+ {
+ *((char *)(strchr (pcp, '\n'))) = EOL;
+#ifdef DEBUG_INPUT
+ printf ("input = '%s'\n", pcp);
+#endif
+
+ /* Store line */
+ if (isdigit (*pcp))
+ insertline();
+
+ /* Process command */
+ else
+ execline();
+ }
+ else
+ quit_flag = TRUE;
+ }
+
+ return (NORMAL);
+
+} /* focal */
A => focalc.bnf +93 -0
@@ 1,93 @@
+(* FOCAL language expression BNF *)
+
+<GOAL> := <EXPR> eos
+ (# value = Stkval(2); #)
+ ;
+
+<EXPR> := <TERM>
+ ! "-" <TERM>
+ (# value = - Stkval(1); #)
+ ! <EXPR> "+" <TERM>
+ (# value = Stkval(3) + Stkval(1); #)
+ ! <EXPR> "-" <TERM>
+ (# value = Stkval(3) - Stkval(1); #)
+ ;
+
+<TERM> := <FACT>
+ ! <TERM> "*" <FACT>
+ (# value = Stkval(3) * Stkval(1); #)
+ ! <TERM> "/" <FACT>
+ (# if (Stkval(1) == 0.0)
+ Parse_Error (INTERP_ERROR, ZERO_DIVIDE);
+ else
+ value = Stkval(3) / Stkval(1); #)
+ ;
+
+<FACT> := <PRIM>
+ ! <FACT> "^" <PRIM>
+ (# if (Stkval(3) == 0.0)
+ value = 0.0;
+ else
+ value = pow(Stkval(3),Stkval(1)); #)
+ ;
+
+<PRIM> := "(" <EXPR> ")"
+ (# value = Stkval(2); #)
+ ! <VARBL>
+ ! num
+ ! <FUNC>
+ ;
+
+<VARBL> := var
+ (# symboltable (CStkval(1), &value, 0, TRUE); #)
+ ! <SUBV>
+ ;
+
+<SUBV> := var "(" <EXPR> ")"
+ (# k = Stkval(2);
+ symboltable (CStkval(4), &value, k, TRUE); #)
+ ;
+
+<FUNC> := fname "(" <EXPR> ")"
+ (# k = Stkval(4); switch (k) {
+ case 1: /* fsqt */
+ if (Stkval(2) < 0.0)
+ Parse_Error (INTERP_ERROR, NEG_SQRT);
+ else
+ value = sqrt(Stkval(2));
+ break;
+ case 2: /* fabs */
+ value = fabs(Stkval(2));
+ break;
+ case 3: /* fsgn */
+ if (Stkval(2) >= 0.0) value = 1.0;
+ else value = -1.0;
+ break;
+ case 4: /* fitr */
+ {int fitr; fitr = Stkval(2); value = fitr;}
+ break;
+ case 5: /* fran */
+ value = rand();
+ while (value > 1.0) value /= 10.0;
+ break;
+ case 6: /* fexp */
+ value = exp(Stkval(2));
+ break;
+ case 7: /* fsin */
+ value = sin(Stkval(2));
+ break;
+ case 8: /* fcos */
+ value = cos(Stkval(2));
+ break;
+ case 9: /* fatn */
+ value = atan(Stkval(2));
+ break;
+ case 10: /* flog */
+ if (Stkval(2) <= 0.0)
+ Parse_Error (INTERP_ERROR, NEG_LOG);
+ else
+ value = log(Stkval(2));
+ break;
+ default:
+ Parse_Error (UNDEF_FUNC, 0); } #)
+ ;
A => focalc.err +99 -0
@@ 1,99 @@
+case 1:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 2:
+ fprintf (stderr, "Missing EOS, '+', '-', ");
+ break;
+case 3:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 4:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 5:
+ fprintf (stderr, "Missing '^', ");
+ break;
+case 6:
+ fprintf (stderr, "Missing ");
+ break;
+case 7:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 8:
+ fprintf (stderr, "Missing ");
+ break;
+case 9:
+ fprintf (stderr, "Missing ");
+ break;
+case 10:
+ fprintf (stderr, "Missing ");
+ break;
+case 11:
+ fprintf (stderr, "Missing '(', ");
+ break;
+case 12:
+ fprintf (stderr, "Missing ");
+ break;
+case 13:
+ fprintf (stderr, "Missing '(', ");
+ break;
+case 14:
+ fprintf (stderr, "Missing ");
+ break;
+case 15:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 16:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 17:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 18:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 19:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 20:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 21:
+ fprintf (stderr, "Missing ')', '+', '-', ");
+ break;
+case 22:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 23:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 24:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 25:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 26:
+ fprintf (stderr, "Missing '^', ");
+ break;
+case 27:
+ fprintf (stderr, "Missing '^', ");
+ break;
+case 28:
+ fprintf (stderr, "Missing ");
+ break;
+case 29:
+ fprintf (stderr, "Missing ");
+ break;
+case 30:
+ fprintf (stderr, "Missing ')', '+', '-', ");
+ break;
+case 31:
+ fprintf (stderr, "Missing ')', '+', '-', ");
+ break;
+case 32:
+ fprintf (stderr, "Missing ");
+ break;
+case 33:
+ fprintf (stderr, "Missing ");
+ break;
A => focalc.ptb +258 -0
@@ 1,258 @@
+/*****************************************************************
+* Parser tables, Generated at Mon Dec 7 14:33:13 2009
+*****************************************************************/
+/*
+** Parser action macros
+*/
+#define SHIFT(co,ar) (ar<<8|co)
+#define REDUCE(co) (co<<8|255)
+#define ERROR -1
+#define GOTO(c,n) (n<<8|(c&255))
+
+/*
+** Parser token type equates
+*/
+#define EOS 3
+#define NUM 15
+#define VAR 17
+#define FNAME 19
+
+/*
+** SLR(1) parser action tables
+*/
+static short int P1[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P2[] = {
+ SHIFT(EOS,14),
+ SHIFT('+',16),
+ SHIFT('-',15),
+ ERROR
+};
+static short int P3[] = {
+ SHIFT('*',17),
+ SHIFT('/',18),
+ REDUCE(2)
+};
+static short int P4[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P5[] = {
+ SHIFT('^',20),
+ REDUCE(6)
+};
+static short int P6[] = {
+ REDUCE(9)
+};
+static short int P7[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P8[] = {
+ REDUCE(12)
+};
+static short int P9[] = {
+ REDUCE(13)
+};
+static short int P10[] = {
+ REDUCE(14)
+};
+static short int P11[] = {
+ SHIFT('(',22),
+ REDUCE(15)
+};
+static short int P12[] = {
+ REDUCE(16)
+};
+static short int P13[] = {
+ SHIFT('(',23),
+ ERROR
+};
+static short int P14[] = {
+ REDUCE(1)
+};
+static short int P15[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P16[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P17[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P18[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P19[] = {
+ SHIFT('*',17),
+ SHIFT('/',18),
+ REDUCE(3)
+};
+static short int P20[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P21[] = {
+ SHIFT(')',29),
+ SHIFT('+',16),
+ SHIFT('-',15),
+ ERROR
+};
+static short int P22[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P23[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P24[] = {
+ SHIFT('*',17),
+ SHIFT('/',18),
+ REDUCE(5)
+};
+static short int P25[] = {
+ SHIFT('*',17),
+ SHIFT('/',18),
+ REDUCE(4)
+};
+static short int P26[] = {
+ SHIFT('^',20),
+ REDUCE(7)
+};
+static short int P27[] = {
+ SHIFT('^',20),
+ REDUCE(8)
+};
+static short int P28[] = {
+ REDUCE(10)
+};
+static short int P29[] = {
+ REDUCE(11)
+};
+static short int P30[] = {
+ SHIFT(')',32),
+ SHIFT('+',16),
+ SHIFT('-',15),
+ ERROR
+};
+static short int P31[] = {
+ SHIFT(')',33),
+ SHIFT('+',16),
+ SHIFT('-',15),
+ ERROR
+};
+static short int P32[] = {
+ REDUCE(17)
+};
+static short int P33[] = {
+ REDUCE(18)
+};
+
+static short int const *parsetable[] = {
+ P1, P2, P3, P4, P5, P6, P7, P8, P9, P10, P11,
+ P12, P13, P14, P15, P16, P17, P18, P19, P20, P21,
+ P22, P23, P24, P25, P26, P27, P28, P29, P30, P31,
+ P32, P33
+};
+
+/*
+** SLR(1) parser goto tables
+*/
+static short int GOAL[] = {
+ GOTO(-1,0)
+};
+static short int EXPR[] = {
+ GOTO(1,2),
+ GOTO(7,21),
+ GOTO(22,30),
+ GOTO(-1,31)
+};
+static short int TERM[] = {
+ GOTO(4,19),
+ GOTO(15,24),
+ GOTO(16,25),
+ GOTO(-1,3)
+};
+static short int FACT[] = {
+ GOTO(17,26),
+ GOTO(18,27),
+ GOTO(-1,5)
+};
+static short int PRIM[] = {
+ GOTO(20,28),
+ GOTO(-1,6)
+};
+static short int VARBL[] = {
+ GOTO(-1,8)
+};
+static short int SUBV[] = {
+ GOTO(-1,12)
+};
+static short int FUNC[] = {
+ GOTO(-1,10)
+};
+
+static struct {
+ short int *go;
+ int handle;
+} const gototable[] = {
+ /* G1 */ GOAL,2,
+ /* G2 */ EXPR,1,
+ /* G3 */ EXPR,2,
+ /* G4 */ EXPR,3,
+ /* G5 */ EXPR,3,
+ /* G6 */ TERM,1,
+ /* G7 */ TERM,3,
+ /* G8 */ TERM,3,
+ /* G9 */ FACT,1,
+ /* G10 */ FACT,3,
+ /* G11 */ PRIM,3,
+ /* G12 */ PRIM,1,
+ /* G13 */ PRIM,1,
+ /* G14 */ PRIM,1,
+ /* G15 */ VARBL,1,
+ /* G16 */ VARBL,1,
+ /* G17 */ SUBV,4,
+ /* G18 */ FUNC,4
+};
A => focalc.sem +80 -0
@@ 1,80 @@
+case 1:
+ value = Stkval(2);
+ break;
+case 3:
+ value = - Stkval(1);
+ break;
+case 4:
+ value = Stkval(3) + Stkval(1);
+ break;
+case 5:
+ value = Stkval(3) - Stkval(1);
+ break;
+case 7:
+ value = Stkval(3) * Stkval(1);
+ break;
+case 8:
+ if (Stkval(1) == 0.0)
+ Parse_Error (INTERP_ERROR, ZERO_DIVIDE);
+ else
+ value = Stkval(3) / Stkval(1);
+ break;
+case 10:
+ if (Stkval(3) == 0.0)
+ value = 0.0;
+ else
+ value = pow(Stkval(3),Stkval(1));
+ break;
+case 11:
+ value = Stkval(2);
+ break;
+case 15:
+ symboltable (CStkval(1), &value, 0, TRUE);
+ break;
+case 17:
+ k = Stkval(2);
+ symboltable (CStkval(4), &value, k, TRUE);
+ break;
+case 18:
+ k = Stkval(4); switch (k) {
+ case 1: /* fsqt */
+ if (Stkval(2) < 0.0)
+ Parse_Error (INTERP_ERROR, NEG_SQRT);
+ else
+ value = sqrt(Stkval(2));
+ break;
+ case 2: /* fabs */
+ value = fabs(Stkval(2));
+ break;
+ case 3: /* fsgn */
+ if (Stkval(2) >= 0.0) value = 1.0;
+ else value = -1.0;
+ break;
+ case 4: /* fitr */
+ {int fitr; fitr = Stkval(2); value = fitr;}
+ break;
+ case 5: /* fran */
+ value = rand();
+ while (value > 1.0) value /= 10.0;
+ break;
+ case 6: /* fexp */
+ value = exp(Stkval(2));
+ break;
+ case 7: /* fsin */
+ value = sin(Stkval(2));
+ break;
+ case 8: /* fcos */
+ value = cos(Stkval(2));
+ break;
+ case 9: /* fatn */
+ value = atan(Stkval(2));
+ break;
+ case 10: /* flog */
+ if (Stkval(2) <= 0.0)
+ Parse_Error (INTERP_ERROR, NEG_LOG);
+ else
+ value = log(Stkval(2));
+ break;
+ default:
+ Parse_Error (UNDEF_FUNC, 0); }
+ break;
A => focalc.tok +4 -0
@@ 1,4 @@
+#define EOS 3
+#define NUM 15
+#define VAR 17
+#define FNAME 19
A => iplot.foc +44 -0
@@ 1,44 @@
+01.05 S IM=31;S RM=61
+01.06 A "ENTER X-AXIS LENGTH"XL;S XL=FABS(XL);I (XL) ,1.06
+01.10 A "ENTER EQUATION ORDER(1,2,3)"IH
+01.20 I (IH-1) 1.5,2.1;
+01.30 I (IH-2) ,3.1;
+01.40 I (IH-3) ,4.1;
+01.50 Q
+02.10 S A2=0;S A3=0;A "ENTER A1"A1"ENTER B"B
+02.20 T !!"EQUATION IS LINEAR "A1"*X+"B"=Y"!!
+02.30 D 5;G 1.1
+03.10 S A3=0;A "ENTER A2"A2"ENTER A1"A1"ENTER B"B
+03.20 T !!"EQUATION IS QUADRATIC "A2"*X^2+"A1"*X+"B"=Y"!!
+03.30 D 5;G 1.1
+04.10 A "ENTER A3"A3"ENTER A2"A2"ENTER A1"A1"ENTER B"B
+04.20 T !!"EQUATION IS CUBIC "A3"*X^3+"A2"*X^2+"A1"*X+"B"=Y"!!
+04.30 D 5;G 1.1
+05.07 T " "
+05.10 T "-30 -20 -10 0 10"
+05.11 T " 20 30"!
+05.13 T " "
+05.14 T " + + + + +"
+05.15 T " + +"!
+05.20 S X=-XL;F I=1,(XL*2+1);D 6
+05.30 R
+06.10 T %7.1,X;S IC=X^3*A3+X^2*A2+X*A1+B+IM
+06.15 S IC=FITR(IC+.5)
+06.20 I (IC-1) 6.25,6.4,6.3
+06.25 S IC=1;G 6.4
+06.30 I (IC-RM) 6.4,6.4
+06.35 S IC=RM
+06.40 I (IC-IM) 6.42,6.8,6.8
+06.42 F J=1,IC;D 7
+06.50 T "*";F J=IC,IM-2;D 7
+06.55 T "!";I (X) 6.99,6.6,6.99
+06.60 F J=IM,RM;D 7
+06.65 G 6.99
+06.80 F J=1,IM;D 7
+06.82 I (IC-IM) ,6.85;T "!";F J=IM,IC-2;D 7
+06.85 T "*";I (X) 6.99,6.9,6.99
+06.90 F J=IC,RM;D 7
+06.99 T !;S X=X+1;R
+07.10 I (X) 7.2,7.3,7.2
+07.20 T " ";R
+07.30 T "-";R
A => link.jcl +24 -0
@@ 1,24 @@
+//DPITTSLF JOB (0),'LINK.FOCAL',
+// MSGCLASS=X,TIME=(10),NOTIFY=DPITTS
+//*
+//LINKM PROC PRDPRFX='DPITTS', < PREFIX FOR PRODUCT DSN
+// LIBPRFX='CEE' < PREFIX FOR LIBRARY DSN
+//LINK EXEC PGM=LINKEDIT,PARM='LIST,MAP,LET'
+//SYSLIB DD DSN=&LIBPRFX..SCEELKED,DISP=SHR
+//SYSUT1 DD UNIT=SYSDA,SPACE=(TRK,(10,5))
+//SYSLMOD DD DSN=&PRDPRFX..TEST.LOADLIB,DISP=SHR
+//MYOBJ DD DSN=&PRDPRFX..TEST.OBJ,DISP=SHR
+//MYLIB DD DSN=&PRDPRFX..TEST.OBJ,DISP=SHR
+//SYSPRINT DD SYSOUT=*
+// PEND
+//*
+//FOCAL EXEC LINKM
+//SYSLIN DD *
+ MODE AMODE(31),RMODE(ANY)
+ INCLUDE MYLIB(GCCMAIN)
+ INCLUDE MYOBJ(FOCAL)
+ INCLUDE MYOBJ(PARSER)
+ INCLUDE MYOBJ(SCREEN)
+ ENTRY CEESTART
+ NAME FOCAL(R)
+//*
A => lunar.foc +47 -0
@@ 1,47 @@
+01.04 T "CONTROL CALLING LUNAR MODULE. MANUAL CONTROL IS NECESSARY"!
+01.06 T "YOU MAY RESET FUEL RATE K EACH 10 SECS TO 0 OR ANY VALUE"!
+01.08 T "BETWEEN 8 & 200 LBS/SEC. YOU'VE 16000 LBS FUEL. ESTIMATED"!
+01.11 T "FREE FALL IMPACT TIME-120 SECS. CAPSULE WEIGHT-32500 LBS"!
+01.20 T "FIRST RADAR CHECK COMING UP"!!!;E
+01.30 T "COMMENCE LANDING PROCEDURE"!"TIME,SECS ALTITUDE,"
+01.40 T "MILES+FEET VELOCITY,MPH FUEL,LBS FUEL RATE"!
+01.50 S A=120;S V=1;S M=32500;S N=16500;S G=.001;S Z=1.8
+
+02.10 T " ",%3,L," ",FITR(A)," ",%4,5280*(A-FITR(A))
+02.20 T %6.02," ",3600*V," ",%6.01,M-N," K=";A K;S T=10
+02.70 T %7.02;I (200-K)2.72;I (8-K)3.1,3.1;I (K)2.72,3.1
+02.72 T "NOT POSSIBLE";F X=1,51;T "."
+02.73 T "K=";A K;G 2.7
+
+03.10 I (M-N-.001)4.1;I (T-.001)2.1;S S=T
+03.40 I ((N+S*K)-M)3.5,3.5;S S=(M-N)/K
+03.50 D 9;I (I)7.1,7.1;I (V)3.8,3.8;I (J)8.1
+03.80 D 6;G 3.1
+
+04.10 T "FUEL OUT AT",L," SECS"!
+04.40 S S=(FSQT(V*V+2*A*G)-V)/G;S V=V+G*S;S L=L+S
+
+05.10 T "ON THE MOON AT",L," SECS"!;S W=3600*V
+05.20 T "IMPACT VELOCITY OF",W,"M.P.H."!,"FUEL LEFT:"M-N," LBS"!
+05.40 I (1-W)5.5,5.5;T "PERFECT LANDING !-(LUCKY)"!;G 5.9
+05.50 I (10-W)5.6,5.6;T "GOOD LANDING-(COULD BE BETTER)"!;G 5.9
+05.60 I (22-W)5.7,5.7;T "CONGRATULATIONS ON A POOR LANDING"!;G 5.9
+05.70 I (40-W)5.81,5.81;T "CRAFT DAMAGE. GOOD LUCK"!;G 5.9
+05.81 I (60-W)5.82,5.82;T "CRASH LANDING-YOU'VE 5 HRS OXYGEN"!;G 5.9
+05.82 T "SORRY,BUT THERE WERE NO SURVIVORS-YOU BLEW IT!"!"IN "
+05.83 T "FACT YOU BLASTED A NEW LUNAR CRATER",W*.277777," FT.DEEP."
+05.90 T !!!!"TRY AGAIN?"!
+05.92 A "(ANS. YES OR NO)"P;I (P-0NO)5.94,5.98
+05.94 I (P-0YES)5.92,1.2,5.92
+05.98 T "CONTROL OUT"!!!;Q
+
+06.10 S L=L+S;S T=T-S;S M=M-S*K;S A=I;S V=J
+
+07.10 I (S-.005)5.1;S S=2*A/(V+FSQT(V*V+2*A*(G-Z*K/M)))
+07.30 D 9;D 6;G 7.1
+
+08.10 S W=(1-M*G/(Z*K))/2;S S=M*V/(Z*K*(W+FSQT(W*W+V/Z)))+.05;D 9
+08.30 I (I)7.1,7.1;D 6;I (-J)3.1,3.1;I (V)3.1,3.1,8.1
+
+09.10 S Q=S*K/M;S J=V+G*S+Z*(-Q-Q^2/2-Q^3/3-Q^4/4-Q^5/5)
+09.40 S I=A-G*S*S/2-V*S+Z*S*(Q/2+Q^2/6+Q^3/12+Q^4/20+Q^5/30)
A => make.com +7 -0
@@ 1,7 @@
+$ set verify
+$ cc /DEF=(VAXVMS,STRERROR,ANSICRT) focal
+$ cc /DEF=(VAXVMS,STRERROR,ANSICRT) parser
+$ cc /DEF=(VAXVMS,STRERROR,ANSICRT) screen
+$ link focal,parser,screen,runtime.opt/opt
+$ purge
+$ set noverify
A => parser.c +599 -0
@@ 1,599 @@
+#if defined(OS390)
+#pragma nomargins
+#pragma nosequence
+#endif
+
+/***********************************************************************
+*
+* Parse - SLR(1) parser
+*
+* This routine interprets the parse tables, generated by CHAT, to
+* perform the SLR(1) parsing actions.
+* Based on Aho and Ullman's parser in "Principles of Compiler Design".
+* A lexical scanner is also included to present the input expression
+* to the parser as a stream of tokens.
+*
+* External routines supplied by the user:
+* Parse_Error (error, state);
+*
+* Files included into the parser:
+* psemant.h - From CHAT, *.sem
+* ptables.h - From CHAT, *.ptb
+* perrors.h - From CHAT, *.err
+* ptokens.h - From CHAT, *.tok
+*
+* errors.h - User produced
+* scanner.h - User produced
+* stables.h - User produced
+*
+* External State machine tables:
+* parsetable - From CHAT, ptables.h
+* gototable - From CHAT, ptables.h
+* chartable - User produced, stables.h
+* scantable - User produced, stables.h
+*
+* This program is free software; you can redistribute it and/or modify it
+* under the terms of the GNU General Public License as published by the
+* Free Software Foundation; either version 2, or (at your option) any
+* later version.
+*
+* This program is distributed in the hope that it will be useful,
+* but WITHOUT ANY WARRANTY; without even the implied warranty of
+* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+* GNU General Public License for more details.
+*
+* You should have received a copy of the GNU General Public License
+* along with this program; if not, write to the Free Software
+* Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+*
+***********************************************************************/
+
+/* System includes */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <ctype.h>
+#include <math.h>
+
+#ifndef TRUE
+#define TRUE 1
+#endif
+
+#ifndef FALSE
+#define FALSE 0
+#endif
+
+
+/* Scanner actions */
+
+#define NULL_ACTION 0x00
+#define ERROR_ACTION 0x01
+#define BACK_ACTION 0x02
+#define MOVE_ACTION 0x04
+#define EAT_ACTION 0x08
+#define BUILD_ACTION 0x10
+
+/* Parser actions */
+
+#define SHIFT_ACTION 0
+#define REDUCE_ACTION 1
+
+/* Local types */
+
+#include "parser.h"
+#define Parse_Error error
+
+#include "errors.h"
+
+/* Stack element */
+
+typedef struct selement {
+ struct selement *link;
+ pstate state;
+ tokval svalue;
+ char cvalue[SYMLEN];
+} selement_t ;
+
+/* Parser tables */
+
+#include "ptables.h"
+
+/* Scanner tables */
+
+#include "stables.h"
+
+/* Local static variables */
+
+static selement_t *stack;
+static selement_t *frees = { NULL };
+
+/* External variables */
+
+#if defined(OS390)
+#define err_flag ERRFLAG
+#endif
+extern int err_flag;
+extern int fpe_stop;
+
+extern char upcase (char);
+
+extern void error (int, int);
+extern void symboltable (char *, tokval *, int, int);
+
+
+/***********************************************************************
+*
+* POP - POP parser stack
+* This routine pops parse states and token values from the parse stack
+* when a reduction is recognized. Put pop'd elements onto a free stack
+* for speed.
+*
+***********************************************************************/
+
+static void
+Pop (int h)
+{
+ selement_t *stemp;
+ int i;
+
+#ifdef DEBUG_PARSE
+ printf ("Pop: h = %d\n", h);
+#endif
+
+ for (i = 0; i < h; i++)
+ {
+ if (stack == NULL)
+ break;
+ else
+ {
+ stemp = stack->link;
+ stack->link = frees;
+ frees = stack;
+ stack = stemp;
+ }
+ } /* of for */
+
+} /* Pop */
+
+/***********************************************************************
+*
+* PUSH - Push parser stack
+* This routine pushes a parse state and token value onto the parse
+* stack. Allocate new elements if free stack is empty.
+*
+***********************************************************************/
+
+static void
+Push (pstate s, tokval v, char *cv)
+{
+ selement_t *stemp;
+
+#ifdef DEBUG_PARSE
+ printf ("Push: state = %d, tokval = %f, toksym = '%s'\n",
+ s, v, cv ? cv : "null");
+#endif
+
+ if (frees == NULL)
+ {
+ stemp = (selement_t *)malloc (sizeof(selement_t));
+ if (stemp == NULL)
+ {
+ Parse_Error (MEM_OVERFLOW, STACK_OVERFLOW);
+ return;
+ }
+ }
+ else
+ {
+ stemp = frees;
+ frees = stemp->link;
+ }
+
+ stemp->state = s;
+ stemp->svalue = v;
+ if (cv != NULL)
+ strcpy (stemp->cvalue, cv);
+ stemp->link = stack;
+ stack = stemp;
+
+} /* Push */
+
+/***********************************************************************
+*
+* Stkval - Get stack value
+* This routine returns the value of a stack element given its position.
+*
+***********************************************************************/
+
+static tokval
+Stkval (int depth)
+{
+ selement_t *stemp;
+ int i;
+
+#ifdef DEBUG_INTERP
+ printf ("Stkval: depth = %d\n", depth);
+#endif
+
+ stemp = stack; /* Find stack element */
+ for (i = 2; i <= depth; i++)
+ {
+ stemp = stemp->link;
+ if (stemp == NULL)
+ return (0.0);
+ }
+#ifdef DEBUG_INTERP
+ printf (" value = %f\n", stemp->svalue);
+#endif
+ return (stemp->svalue);
+
+} /* Stkval */
+
+/***********************************************************************
+*
+* CStkval - Get char stack value
+* This routine returns a pointer to the character value of a stack
+* element given its position.
+*
+***********************************************************************/
+
+static char *
+CStkval (int depth)
+{
+ selement_t *stemp;
+ int i;
+
+#ifdef DEBUG_INTERP
+ printf ("CStkval: depth = %d\n", depth);
+#endif
+
+ stemp = stack; /* Find stack element */
+ for (i = 2; i <= depth; i++)
+ {
+ stemp = stemp->link;
+ if (stemp == NULL)
+ return (NULL);
+ }
+#ifdef DEBUG_INTERP
+ printf (" value = '%s'\n", stemp->cvalue);
+#endif
+ return (stemp->cvalue);
+
+} /* CStkval */
+
+/***********************************************************************
+*
+* TOP - Get current parse state
+* This routine return the parse state from the top element of the
+* parse stack.
+*
+***********************************************************************/
+
+static pstate
+Top (void)
+{
+ return (stack->state);
+}
+
+/***********************************************************************
+*
+* Interpret - Interpret syntactical reduction
+* This routine adds the semantic interpretation to the recognition of
+* syntactical reductions.
+*
+***********************************************************************/
+
+static tokval
+Interpret (pstate r)
+{
+ tokval value;
+ int k;
+ char symbol[SYMLEN];
+
+#ifdef DEBUG_INTERP
+ printf ("Interpret: red = %d\n", r);
+#endif
+
+ value = 0.0;
+ symbol[0] = '\0';
+ switch (r)
+ {
+
+ /* Get the generated semantic actions */
+#include "psemant.h"
+
+ default:
+ value = Stkval(1);
+ }
+
+ return (value);
+
+} /* Interp */
+
+/***********************************************************************
+*
+* Scanner - Lexical scanner
+* This routine is a table driven scanner used to lexically analyze
+* source input. Scanner is called whenever the parser needs the next
+* token in the input stream. The scanner is implemented as a finite
+* state machine.
+*
+***********************************************************************/
+
+static toktyp
+Scanner (char expr[], int *ndx, tokval *svalue, char *toksym)
+{
+ tokval sexp, sfrc, dignum, expsgn, value;
+ int i, sdx;
+ word sa, *pt;
+ toktyp token;
+ byte chr, next, action;
+ byte select;
+ byte current_state; /* Scanner current state */
+ char lachar, latran; /* Look ahead character */
+ char symbol[SYMLEN]; /* Collected symbol */
+
+#ifdef DEBUG_SCAN
+ printf ("Scanner entered:\n");
+#endif
+
+ value = 0.0; /* Initialization */
+ sexp = 0.0;
+ sfrc = 0.1;
+ expsgn = 1.0;
+ sdx = 0;
+ symbol[sdx] = '\0';
+
+ current_state = 1; /* Initialize current state */
+
+ do
+ {
+
+ lachar = expr[*ndx]; /* Get current input char */
+ latran = chartable[lachar]; /* Classify the character */
+
+#ifdef DEBUG_SCAN
+ printf (" cs = %d, lachar = %02x, latran = %d\n",
+ current_state, lachar, latran);
+#endif
+
+ dignum = 0.0;
+ if (isdigit(lachar)) /* Convert digit to real number */
+ dignum = (lachar - '0');
+
+ /* Find state transition given current state and input character */
+
+ pt = (word *)scantable[current_state-1];
+
+ for (i = 0 ;; i++)
+ {
+
+ sa = *pt++;
+ action = sa & 31;
+ next = (sa >> 5) & 63;
+ chr = (sa >> 11) & 31;
+
+#ifdef DEBUG_SCAN
+ printf (" Si = %d, a = %02x, n = %d, c = %d\n", i, action, next, chr);
+#endif
+
+ if ((chr == latran) || (chr == 31)) /* State transition fnd. */
+ {
+
+ /* Perform the scan action for this transition */
+
+ if (ERROR_ACTION & action) /* Error, terminate scan */
+ {
+#ifdef DEBUG_SCAN
+ printf (" ERROR: \n");
+#endif
+ Parse_Error (SCAN_ERROR, current_state);
+ return (0);
+ }
+
+ if (BACK_ACTION & action) /* Back up in input stream */
+ {
+#ifdef DEBUG_SCAN
+ printf (" BACK:\n");
+#endif
+ *ndx = *ndx - 1;
+ }
+
+ if (EAT_ACTION & action) /* Eat (ignore) character */
+ {
+#ifdef DEBUG_SCAN
+ printf (" EAT:\n");
+#endif
+ *ndx = *ndx + 1;
+ }
+
+ if (MOVE_ACTION & action) /* Move to symbol */
+ {
+#ifdef DEBUG_SCAN
+ printf (" MOVE: \n");
+#endif
+ if (sdx < SYMLEN)
+ {
+ symbol[sdx] = upcase(lachar);
+ sdx ++;
+ symbol[sdx] = '\0';
+ }
+ }
+
+ if (BUILD_ACTION & action) /* Token found process it */
+ {
+ if (next == 0) select = current_state;
+ else select = next;
+#ifdef DEBUG_SCAN
+ printf (" BUILD: select = %d\n", select);
+#endif
+ switch (select)
+ {
+
+ /* Get the scanner actions */
+#include "scanner.h"
+
+ }
+ }
+
+ current_state = next; /* Goto new scan state */
+ break;
+
+ }
+ }
+
+ } while (current_state != 0);
+
+#ifdef DEBUG_SCAN
+ printf (" token = %d, val = %10.4f\n", token, value);
+#endif
+
+ *svalue = value;
+ strcpy (toksym, symbol);
+
+ return (token);
+
+} /* Scanner */
+
+/***********************************************************************
+*
+* Parser - SLR(1) parser
+* This routine interprets the parse tables to perform the SLR(1)
+* parsing actions.
+*
+***********************************************************************/
+
+tokval
+Parser (char *expr)
+{
+ word *pt, *gp;
+ tokval value, rvalue;
+ int i, j, index;
+ word pa, tok, act;
+ toktyp token;
+ pstate current_state, c_s;
+ pstate next, crnt;
+ pstate sr;
+ char toksym[SYMLEN];
+
+#ifdef DEBUG_PARSE
+ printf ("Parse Entered:\n");
+#endif
+
+ index = 0;
+ current_state = 1;
+ stack = NULL;
+ err_flag = FALSE;
+ toksym[0] = '\0';
+
+ Push (current_state, 0.0, NULL);
+
+ /* Get look ahead input token */
+ token = Scanner (expr, &index, &value, toksym);
+
+ do
+ {
+
+ /* Get action entry for current state, look ahead token */
+
+ pt = (word *)parsetable[current_state-1];
+
+ for (i = 0 ;; i++)
+ {
+
+ pa = *pt++;
+ tok = pa & 127;
+ act = (pa >> 7) & 1;
+ sr = (pa >> 8) & 255;
+
+#ifdef DEBUG_PARSE
+ printf (" Pi = %d, t = %d, a = %d, sr = %d\n", i, tok, act, sr);
+#endif
+
+ if ((tok == 127) || (tok == token))
+ {
+
+ /* State action found - do error, shift or reduce action */
+
+ if ((sr == 255) || err_flag)
+ {
+ if (! err_flag) /* Error processor - user defined */
+ Parse_Error (PARSE_ERROR, current_state);
+ Pop (1000);
+ return (value);
+ }
+
+ if (act == SHIFT_ACTION)
+ {
+
+#ifdef DEBUG_PARSE
+ printf (" Shift, value = %10.4f\n", value);
+#endif
+
+ Push (sr, value, toksym);
+ token = Scanner (expr, &index, &value, toksym);
+ }
+
+ else /* REDUCE_ACTION */
+ {
+ rvalue = Interpret (sr);
+ if (fpe_stop)
+ {
+ Pop (1000);
+ return (value);
+ }
+
+#ifdef DEBUG_PARSE
+ printf (" Reduce, sr = %d, rvalue = %10.4f\n", sr, rvalue);
+ printf (" Handle = %d\n", gototable[sr-1].handle);
+#endif
+
+ Pop (gototable[sr-1].handle);
+ c_s = Top();
+
+#ifdef DEBUG_PARSE
+ printf (" TOP-state = %d\n", c_s);
+#endif
+
+ /* Use goto tables to get next state */
+
+ gp = (word *) gototable[sr-1].go;
+
+ for (j = 0 ;; j++)
+ {
+
+ pa = *gp++;
+ crnt = pa & 255;
+ next = (pa >> 8) & 255;
+
+#ifdef DEBUG_PARSE
+ printf (" j = %d, crnt = %d, next = %d\n", j, crnt, next);
+#endif
+
+ if ((crnt == c_s) || (crnt == 255))
+ {
+ Push (next, rvalue, NULL);
+ break;
+ }
+
+ } /* for j */
+
+ }
+ break;
+ }
+
+ } /* for i */
+
+ current_state = Top();
+
+#ifdef DEBUG_PARSE
+ printf (" Cursta = %d\n", current_state);
+#endif
+
+ } while (current_state != 0); /* Until input is accepted */
+
+ Pop (50); /* Purge stack of possible leftovers */
+
+ return (rvalue);
+
+} /* Parser */
A => parser.h +23 -0
@@ 1,23 @@
+/***********************************************************************
+* File = parser.h
+***********************************************************************/
+
+#define SYMLEN 10
+
+typedef char int8;
+typedef short int16;
+typedef long int32;
+typedef unsigned char byte;
+typedef unsigned short word;
+typedef unsigned long dword;
+
+typedef byte tchar; /* 0..255 */
+typedef byte pstate; /* 0..255 */
+typedef int8 toktyp; /* 0..0x7F */
+typedef double tokval;
+
+#if defined(OS390)
+#define Parser PARSER
+#endif
+extern tokval Parser ( );
+
A => perrors.h +99 -0
@@ 1,99 @@
+case 1:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 2:
+ fprintf (stderr, "Missing EOS, '+', '-', ");
+ break;
+case 3:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 4:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 5:
+ fprintf (stderr, "Missing '^', ");
+ break;
+case 6:
+ fprintf (stderr, "Missing ");
+ break;
+case 7:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 8:
+ fprintf (stderr, "Missing ");
+ break;
+case 9:
+ fprintf (stderr, "Missing ");
+ break;
+case 10:
+ fprintf (stderr, "Missing ");
+ break;
+case 11:
+ fprintf (stderr, "Missing '(', ");
+ break;
+case 12:
+ fprintf (stderr, "Missing ");
+ break;
+case 13:
+ fprintf (stderr, "Missing '(', ");
+ break;
+case 14:
+ fprintf (stderr, "Missing ");
+ break;
+case 15:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 16:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 17:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 18:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 19:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 20:
+ fprintf (stderr, "Missing '(', NUM, VAR, FNAME, ");
+ break;
+case 21:
+ fprintf (stderr, "Missing ')', '+', '-', ");
+ break;
+case 22:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 23:
+ fprintf (stderr, "Missing '-', '(', NUM, VAR, FNAME, ");
+ break;
+case 24:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 25:
+ fprintf (stderr, "Missing '*', '/', ");
+ break;
+case 26:
+ fprintf (stderr, "Missing '^', ");
+ break;
+case 27:
+ fprintf (stderr, "Missing '^', ");
+ break;
+case 28:
+ fprintf (stderr, "Missing ");
+ break;
+case 29:
+ fprintf (stderr, "Missing ");
+ break;
+case 30:
+ fprintf (stderr, "Missing ')', '+', '-', ");
+ break;
+case 31:
+ fprintf (stderr, "Missing ')', '+', '-', ");
+ break;
+case 32:
+ fprintf (stderr, "Missing ");
+ break;
+case 33:
+ fprintf (stderr, "Missing ");
+ break;
A => primes.foc +21 -0
@@ 1,21 @@
+10.05 t "List of prime numbers",!
+10.10 s size = 1000
+10.15 s l = 0
+10.20 f i = 1, size;s iflags(i) = 1
+10.30 s iflags(1) = 0
+10.40 f num = 1, size; do 20
+10.50 f num = 1, size; do 30
+10.60 t !
+10.90 q
+20.10 i (iflags(num)) 20.20, 20.90, 20.20
+20.20 s prime = num
+20.30 s mult = prime + prime
+20.40 i (mult-size) 20.50, 20.50, 20.90
+20.50 f i = mult, prime, size;s iflags(i) = 0
+20.90 r
+30.10 i (iflags(num)) 30.90, 30.90
+30.20 t %5, num, " "
+30.30 s l=l+1
+30.40 i (l-9) 30.90
+30.50 t !;s l=0
+30.90 r
A => psemant.h +80 -0
@@ 1,80 @@
+case 1:
+ value = Stkval(2);
+ break;
+case 3:
+ value = - Stkval(1);
+ break;
+case 4:
+ value = Stkval(3) + Stkval(1);
+ break;
+case 5:
+ value = Stkval(3) - Stkval(1);
+ break;
+case 7:
+ value = Stkval(3) * Stkval(1);
+ break;
+case 8:
+ if (Stkval(1) == 0.0)
+ Parse_Error (INTERP_ERROR, ZERO_DIVIDE);
+ else
+ value = Stkval(3) / Stkval(1);
+ break;
+case 10:
+ if (Stkval(3) == 0.0)
+ value = 0.0;
+ else
+ value = pow(Stkval(3),Stkval(1));
+ break;
+case 11:
+ value = Stkval(2);
+ break;
+case 15:
+ symboltable (CStkval(1), &value, 0, TRUE);
+ break;
+case 17:
+ k = Stkval(2);
+ symboltable (CStkval(4), &value, k, TRUE);
+ break;
+case 18:
+ k = Stkval(4); switch (k) {
+ case 1: /* fsqt */
+ if (Stkval(2) < 0.0)
+ Parse_Error (INTERP_ERROR, NEG_SQRT);
+ else
+ value = sqrt(Stkval(2));
+ break;
+ case 2: /* fabs */
+ value = fabs(Stkval(2));
+ break;
+ case 3: /* fsgn */
+ if (Stkval(2) >= 0.0) value = 1.0;
+ else value = -1.0;
+ break;
+ case 4: /* fitr */
+ {int fitr; fitr = Stkval(2); value = fitr;}
+ break;
+ case 5: /* fran */
+ value = rand();
+ while (value > 1.0) value /= 10.0;
+ break;
+ case 6: /* fexp */
+ value = exp(Stkval(2));
+ break;
+ case 7: /* fsin */
+ value = sin(Stkval(2));
+ break;
+ case 8: /* fcos */
+ value = cos(Stkval(2));
+ break;
+ case 9: /* fatn */
+ value = atan(Stkval(2));
+ break;
+ case 10: /* flog */
+ if (Stkval(2) <= 0.0)
+ Parse_Error (INTERP_ERROR, NEG_LOG);
+ else
+ value = log(Stkval(2));
+ break;
+ default:
+ Parse_Error (UNDEF_FUNC, 0); }
+ break;
A => ptables.h +258 -0
@@ 1,258 @@
+/*****************************************************************
+* Parser tables, Generated at Mon Dec 7 14:33:13 2009
+*****************************************************************/
+/*
+** Parser action macros
+*/
+#define SHIFT(co,ar) (ar<<8|co)
+#define REDUCE(co) (co<<8|255)
+#define ERROR -1
+#define GOTO(c,n) (n<<8|(c&255))
+
+/*
+** Parser token type equates
+*/
+#define EOS 3
+#define NUM 15
+#define VAR 17
+#define FNAME 19
+
+/*
+** SLR(1) parser action tables
+*/
+static short int P1[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P2[] = {
+ SHIFT(EOS,14),
+ SHIFT('+',16),
+ SHIFT('-',15),
+ ERROR
+};
+static short int P3[] = {
+ SHIFT('*',17),
+ SHIFT('/',18),
+ REDUCE(2)
+};
+static short int P4[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P5[] = {
+ SHIFT('^',20),
+ REDUCE(6)
+};
+static short int P6[] = {
+ REDUCE(9)
+};
+static short int P7[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P8[] = {
+ REDUCE(12)
+};
+static short int P9[] = {
+ REDUCE(13)
+};
+static short int P10[] = {
+ REDUCE(14)
+};
+static short int P11[] = {
+ SHIFT('(',22),
+ REDUCE(15)
+};
+static short int P12[] = {
+ REDUCE(16)
+};
+static short int P13[] = {
+ SHIFT('(',23),
+ ERROR
+};
+static short int P14[] = {
+ REDUCE(1)
+};
+static short int P15[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P16[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P17[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P18[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P19[] = {
+ SHIFT('*',17),
+ SHIFT('/',18),
+ REDUCE(3)
+};
+static short int P20[] = {
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};
+static short int P21[] = {
+ SHIFT(')',29),
+ SHIFT('+',16),
+ SHIFT('-',15),
+ ERROR
+};
+static short int P22[] = {
+ SHIFT('-',4),
+ SHIFT('(',7),
+ SHIFT(NUM,9),
+ SHIFT(VAR,11),
+ SHIFT(FNAME,13),
+ ERROR
+};