├── .gitattributes ├── .gitignore ├── .gitmodules ├── CHANGELOG.md ├── LICENSE ├── LÉIGHMÉ.md ├── Makefile ├── README.md ├── README.orig ├── bin ├── Makefile └── README.md ├── build ├── ccd-gcc └── install ├── contrib ├── README ├── pdcdsys.c ├── pdcfreeb.c ├── pdcfreeb.h ├── pdcsun.c └── pdcsun.h ├── doc └── whitepaper1.txt ├── hooks └── pre-commit ├── samples ├── README.md ├── examples │ ├── autorep.lst │ ├── awaytofile1.lst │ ├── awaytofile2.lst │ ├── computer.lst │ ├── computer.md │ ├── deco.lst │ ├── gtk_server.lst │ ├── hammurabi.lst │ ├── hex.lst │ ├── mbutton.lst │ ├── prime.lst │ ├── slpl.lst │ ├── slpl.txt │ ├── standard.lst │ ├── standard.md │ ├── trees1.lst │ ├── truefalse.lst │ ├── verbaal.lst │ ├── verbaal_proc.lst │ └── verbaal_test.lst └── tests │ ├── aap1.prl │ ├── aap3.prl │ ├── abs()1.lst │ ├── acs()1.lst │ ├── append1.lst │ ├── arr1.lst │ ├── asn()1.lst │ ├── assign1.lst │ ├── atn()1.lst │ ├── bigarray.lst │ ├── bigstr.lst │ ├── case1.lst │ ├── check.prl │ ├── chr$()1.lst │ ├── close1.lst │ ├── closed1.lst │ ├── closed2.lst │ ├── common.lst │ ├── common_external.lst │ ├── common_file.lst │ ├── common_string.lst │ ├── common_using.lst │ ├── cos()1.lst │ ├── cursor1.lst │ ├── deg()1.lst │ ├── delete1.lst │ ├── deliet.prc │ ├── deliet.prl │ ├── dim1.lst │ ├── dim2.lst │ ├── dim3.lst │ ├── dirs.lst │ ├── end1.lst │ ├── eod1.lst │ ├── eof()1.lst │ ├── exp()1.lst │ ├── externa1.lst │ ├── externa2.lst │ ├── externa3.lst │ ├── externa4.lst │ ├── externa5.lst │ ├── false1.lst │ ├── for1.lst │ ├── func1.lst │ ├── func2.lst │ ├── gentest.lst │ ├── hex.prl │ ├── id1.lst │ ├── id2.lst │ ├── if1.lst │ ├── import1.lst │ ├── import2.lst │ ├── input#1.lst │ ├── input1.lst │ ├── int()1.lst │ ├── len()1.lst │ ├── local1.lst │ ├── log()1.lst │ ├── log10()1.lst │ ├── logist1.lst │ ├── logist2.lst │ ├── logop1.lst │ ├── loop1.lst │ ├── lst2sq.lst │ ├── name1.lst │ ├── not()1.lst │ ├── null1.lst │ ├── op_assig.lst │ ├── ord()1.lst │ ├── page1.lst │ ├── pass1.lst │ ├── pi1.lst │ ├── print#1.lst │ ├── proc1.lst │ ├── proc2.lst │ ├── proc3.lst │ ├── proc4.lst │ ├── proc5.lst │ ├── rad()1.lst │ ├── random1.lst │ ├── random2.lst │ ├── read#1.lst │ ├── read1.lst │ ├── read2.lst │ ├── ref1.lst │ ├── repeat1.lst │ ├── repeat2.lst │ ├── repeat3.lst │ ├── restore1.lst │ ├── retry1.lst │ ├── rnd()1.lst │ ├── rnd()2.lst │ ├── rnd()3.lst │ ├── rnd()4.lst │ ├── rnd()5.lst │ ├── rnd()6.lst │ ├── round1.lst │ ├── run1.lst │ ├── run1a.lst │ ├── selin1.lst │ ├── selout1.lst │ ├── sgn()1.lst │ ├── signif1.lst │ ├── sin()1.lst │ ├── spc$.lst │ ├── spc$2.lst │ ├── sq2lst.lst │ ├── sqr()1.lst │ ├── stop1.lst │ ├── str$()1.lst │ ├── stringmul.lst │ ├── substr1.lst │ ├── substr2.lst │ ├── sys1.lst │ ├── tan()1.lst │ ├── trace1.lst │ ├── trap1.lst │ ├── trap2.lst │ ├── trap3.lst │ ├── true1.lst │ ├── using1.lst │ ├── val()1.lst │ ├── while1.lst │ └── write1.lst ├── src ├── BUILD ├── Doxyfile ├── Makefile ├── Makefile.bak ├── VERSION ├── compat_cdefs.h ├── en.msg ├── ga.msg ├── gcc.mk ├── header ├── linux.mk ├── long.c ├── long.h ├── macos.mk ├── pdccloop.c ├── pdccloop.h ├── pdccmd.c ├── pdccmd.h ├── pdcconst.h ├── pdcdef.h ├── pdcdsys.h ├── pdcenv.c ├── pdcenv.h ├── pdcerr.h ├── pdcexec.c ├── pdcexec.h ├── pdcexp.c ├── pdcexp.h ├── pdcext.c ├── pdcext.h ├── pdcfree.c ├── pdcfree.h ├── pdcfunc.h ├── pdcglob.h ├── pdcid.c ├── pdcid.h ├── pdclex.l ├── pdclexs.c ├── pdclexs.h ├── pdclist.c ├── pdclist.h ├── pdcmain.c ├── pdcmem.c ├── pdcmem.h ├── pdcmisc.c ├── pdcmisc.h ├── pdcmod.c ├── pdcmod.h ├── pdcmsg.h ├── pdcnana.h ├── pdcpars.y ├── pdcparss.c ├── pdcparss.h ├── pdcprog.c ├── pdcprog.h ├── pdcrun.c ├── pdcrun.h ├── pdcscan.c ├── pdcscan.h ├── pdcseg.c ├── pdcseg.h ├── pdcsqash.c ├── pdcsqash.h ├── pdcstr.c ├── pdcstr.h ├── pdcsym.c ├── pdcsym.h ├── pdcsys.h ├── pdcunix.c ├── pdcunix.h ├── pdcval.c ├── pdcval.h ├── pgcc.mk └── version.h └── tools ├── bumpbuild ├── cml-indent ├── gentar ├── genversion └── mkcatdefs.c /.gitattributes: -------------------------------------------------------------------------------- 1 | #common settings that generally should always be used with your language specific settings 2 | 3 | # Auto detect text files and perform LF normalization 4 | # http://davidlaing.com/2012/09/19/customise-your-gitattributes-to-become-a-git-ninja/ 5 | * text=auto 6 | 7 | # 8 | # The above will handle all files NOT found below 9 | # 10 | 11 | # Documents 12 | *.doc diff=astextplain 13 | *.DOC diff=astextplain 14 | *.docx diff=astextplain 15 | *.DOCX diff=astextplain 16 | *.dot diff=astextplain 17 | *.DOT diff=astextplain 18 | *.pdf diff=astextplain 19 | *.PDF diff=astextplain 20 | *.rtf diff=astextplain 21 | *.RTF diff=astextplain 22 | *.md text 23 | *.adoc text 24 | *.textile text 25 | *.mustache text 26 | *.csv text 27 | *.tab text 28 | *.tsv text 29 | *.sql text 30 | 31 | # Graphics 32 | *.png binary 33 | *.jpg binary 34 | *.jpeg binary 35 | *.gif binary 36 | *.tif binary 37 | *.tiff binary 38 | *.ico binary 39 | *.svg binary 40 | *.eps binary 41 | 42 | #sources 43 | *.C text 44 | *.cc text 45 | *.cxx text 46 | *.cpp text 47 | *.c++ text 48 | *.c text 49 | *.hpp text 50 | *.h text 51 | *.h++ text 52 | *.hh text 53 | 54 | # X/Open Message Catalogs 55 | *.msg encoding=latin-9 56 | 57 | # Compiled Object files 58 | *.slo binary 59 | *.lo binary 60 | *.o binary 61 | *.obj binary 62 | 63 | # Precompiled Headers 64 | *.gch binary 65 | *.pch binary 66 | 67 | # Compiled Dynamic libraries 68 | *.so binary 69 | *.dylib binary 70 | *.dll binary 71 | 72 | # Compiled Static libraries 73 | *.lai binary 74 | *.la binary 75 | *.a binary 76 | *.lib binary 77 | 78 | # Executables 79 | *.exe binary 80 | *.out binary 81 | *.app binary 82 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Object files 2 | *.o 3 | *.ko 4 | 5 | # Libraries 6 | *.lib 7 | *.a 8 | 9 | # Shared objects (inc. Windows DLLs) 10 | *.dll 11 | *.so 12 | *.so.* 13 | *.dylib 14 | 15 | # Executables 16 | *.exe 17 | *.out 18 | *.app 19 | 20 | *~ 21 | *.sq 22 | *.prc 23 | *.cml 24 | *.d 25 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "cii"] 2 | path = cii 3 | url = https://github.com/drh/cii.git 4 | [submodule "nana"] 5 | path = nana 6 | url = https://github.com/pjmaker/nana.git 7 | -------------------------------------------------------------------------------- /LÉIGHMÉ.md: -------------------------------------------------------------------------------- 1 | # OpenCOMAL 2 | 3 | Féach ar an [Wiki](https://github.com/poldy/OpenCOMAL/wiki) 4 | don chuid is mó de na cáipéisí. 5 | 6 | Seo beagáinín athruithe cóip den eagrán neamhcríochnaithe 7 | [0.2.7](http://www.josvisser.nl/opencomal/opencomal-0.2.7-pre1-work.tar.gz) 8 | [OpenComal](http://www.josvisser.nl/opencomal) 9 | ag [Jos Visser](http://www.josvisser.nl/). 10 | 11 | ## Ceisteanna atá Curtha go Minic 12 | 13 | ### Cén fáth a rinne mé an cóip seo 14 | 15 | Buíochas le pietsch , 16 | a choimeád OpenCOMAL ag obair ar feadh cúpla blianta. 17 | 18 | Tá suim agam i slíneann praticiúla chun sean-bhogearraí a dhéanamh níos fearr, 19 | cosúil leis an tionscadal [ntpsec](https://www.ntpsec.org/). 20 | Tá OpenCOMAL deas beag chun é seo a fhoghlaim. 21 | 22 | Ba mhaith liom gurbh fhéidir leis an clár rudaí nua a dhéanamh: 23 | - Téacs Gaeilge a bheith sa chlár, agus sa chomhrá leis an duine 24 | - Bheith níos gearr leis na caighdeáin "[COMAL Kernel](http://datamuseum.dk/wiki/COMAL/standardization#TeleNova.2C_Nyn.C3.A4shamn.2C_Sweden._March_13_to_16.2C_1985)" agus "[Common COMAL](https://computerarchive.org/files/computer/newsletters/comal-today/COMAL_Today_Issue_24.pdf)". Is rud a thatnaíonn liom iad caighdeáin neamhspleáchanna mar seo. 25 | - Bheith in ann pacáiste ar nós "[Standard](samples/examples/standard.md)" agus "[Type Detector](samples/examples/computer.md)" a úsáid 26 | 27 | Níl an obair seo críochnaithe in aon chor fós. Más mian le éinne cuidiú 28 | liom, seol "pull request" dom le do thoil. 29 | 30 | Tabhair faoi dear nach raibh mé in ann an bogearra seo a choimeád ag obair ar 31 | an córas oibriú Windows, 32 | gabh mo leithscéal. 33 | 34 | ### Cad a smaoineann an t-údar Jos Visser faoin cóip seo? 35 | 36 | Níl fhios agam. 37 | Sheol me ríomhphostanna chuig a sheoladh, ach is dócha nach raibh siad léite. 38 | Ó taobh na dlí de, níl fadhb ar bith ann mar tá OpenCOMAL ceadaithe faoin GPL. 39 | 40 | ### Ní feicim uimhir don líne nua tar éis `auto` a chur isteach. An bhfuil sé seo mícheart? 41 | 42 | Ná bac leis, ach rud éigin a chur isteach agus feicfidh tú é. 43 | Nó buail leis an cló backspace ar dtús (buíochas le Harald Arnesen do seo). 44 | 45 | ### Cathain a athróidh tú an bogearra seo chun go bhféadfaidh me X a dhéanamh? 46 | 47 | Ní mhiste liom é seo a dhéanamh, muna bhfuil X i gceann de na caighdeáin thuas. 48 | *Tá* suim agam i fadhbanna agus cabhair o daoine eile. 49 | Ceapaim go bhfuil OpenCOMAL suimiúl o thaobh na stair de, 50 | agus b'fhéidir go bhfuil sé oiriúnach do foghlaimeoirí freisin. 51 | 52 | ## Níos Mó á Léamh 53 | 54 | Féach ar na nascanna ag deireadh an [leagan Béarla](README.md) den cáipéis seo. 55 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .POSIX: 2 | .DELETE_ON_ERROR: 3 | 4 | # This Makefile is for people who just type make whenever 5 | # they see a Makefile somewhere... :-) 6 | # 7 | # Reading the README is a better way 8 | 9 | PREFIX?=/usr/local 10 | PARALLEL?=-j -l 2.5 11 | REALCC?=gcc 12 | OPSYS?=linux 13 | 14 | .PHONY: top 15 | top: msg all 16 | 17 | .PHONY: msg 18 | msg: 19 | @echo 20 | @echo Aha, you are one of these persons that types make 21 | @echo whenever they see a Makefile somewhere.... 22 | @echo 23 | 24 | .PHONY: all 25 | all: 26 | +@cd src; $(MAKE) $(PARALLEL) DEBUG=$(DEBUG) OPSYS=$(OPSYS) REALCC=$(REALCC) 27 | 28 | .PHONY: install 29 | install: 30 | cd bin ; $(MAKE) install PREFIX=$(PREFIX) OPSYS=$(OPSYS) REALCC=$(REALCC) 31 | 32 | .PHONY: clean 33 | clean: 34 | cd src; $(MAKE) clean OPSYS=$(OPSYS) REALCC=$(REALCC) 35 | 36 | .PHONY: tar 37 | tar: src 38 | cd src; $(MAKE) almostclean OPSYS=$(OPSYS) REALCC=$(REALCC) 39 | -cd bin; strip opencomal opencomalrun 40 | tools/gentar 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # OpenCOMAL 2 | 3 | See the [Wiki](https://github.com/poldy/OpenCOMAL/wiki) for most of the 4 | documentation. 5 | 6 | (Tá [leagan Gaeilge](LÉIGHMÉ.md) den cáipéis seo ar fáil.) 7 | 8 | This is a patched version of [Jos Visser](http://www.josvisser.nl/)'s 9 | [OpenComal](http://www.josvisser.nl/opencomal/) 10 | [0.2.7](http://www.josvisser.nl/opencomal/opencomal-0.2.7-pre1-work.tar.gz) (unstable branch). 11 | 12 | ## FAQ 13 | 14 | ### Why this fork? 15 | 16 | The previous maintainer, pietsch , fixed 17 | bugs so that OpenComal could run on then-current versions of Linux. 18 | 19 | I took over the project because I am interested in practical 20 | methods for improving the quality of old projects (similar to the 21 | [ntpsec](https://www.ntpsec.org/) project, although I am still 22 | some way behind them). OpenComal is a nice size to run experiments 23 | on. 24 | 25 | One of the nice things about the COMAL language itself is 26 | that it has a vendor-neutral standard with several implementions. 27 | Lately I've also been trying to bring OpenComal closer to compliance 28 | with those standards: 29 | 30 | * [COMAL Kernel spec](http://datamuseum.dk/wiki/COMAL/standardization#TeleNova.2C_Nyn.C3.A4shamn.2C_Sweden._March_13_to_16.2C_1985) 31 | * [Common COMAL](https://archive.org/download/COMAL_Today_Issue_24), pages 21-46 32 | * [The "Type Detector" package](samples/examples/computer.md) 33 | * [The "STANDARD" package](samples/examples/standard.md) 34 | 35 | One regression is that I removed support for platforms that I don't 36 | build and test, MS-DOS and Win32. 37 | I am no longer interested in these systems, or pull requests for them. 38 | Just in case anyone wanted to fork, 39 | the last version containing the needed files is tagged as `last_dos_w32_version`. 40 | 41 | ### Does Jos Visser, the original author, endorse this fork? 42 | 43 | I don't know. 44 | Emails sent to his address no longer seem to be read. 45 | Legally there should not 46 | be any problem because OpenComal is licensed under the GPL. 47 | 48 | ### I do not see a new line number after entering `auto`. Is this wrong? 49 | 50 | Never mind, just type anything, and it will appear. Or hit the 51 | backspace key first (kudos to Harald Arnesen for this hint). 52 | 53 | ### When will you implement feature X? 54 | 55 | I'm reluctant to do this, unless the feature is in one of the above 56 | standards. I *am* interested in bug reports and pull requests 57 | though. I think OpenCOMAL definitely has a niche in retrocomputing 58 | and may possibly have one in education, e.g. for children, teenagers, or 59 | other domain experts 60 | that don't have time to learn Computer Science. 61 | 62 | ## Further Reading 63 | 64 | ### included: 65 | * [original README](README.orig) 66 | * [TODO](https://github.com/poldy/OpenCOMAL/wiki/TODO) 67 | * [original documentation](doc/) 68 | 69 | ### external: 70 | * [Børge R. Christensen's COMAL Reference Guide (for COMAL 0.14 on the C-64)](http://www.c64-wiki.de/index.php/COMAL_Reference_Guide) 71 | * Wikipedia has useful COMAL entries in 72 | [German](https://de.wikipedia.org/wiki/COMAL), 73 | [English](https://en.wikipedia.org/wiki/COMAL), and 74 | [Polish](https://pl.wikipedia.org/wiki/Comal). 75 | -------------------------------------------------------------------------------- /README.orig: -------------------------------------------------------------------------------- 1 | ------------- 2 | OpenComal 0.2 3 | ------------- 4 | 5 | I am: Jos Visser 6 | Date: Sun Sep 8 09:51:32 CEST 2002 7 | 8 | Thou art looking at the README file of OpenComal. Before you continue, 9 | thank you very much for downloading my software and taking the time to 10 | investigate it. Your interest and feedback is much appreciated... 11 | 12 | OpenComal is a free implementation of the Comal programming language. 13 | For more information on (Open)Comal, check out the high quality 14 | documentation in the doc/ subdirectory... :-) 15 | 16 | This release of OpenComal has been built and tested on the Linux 17 | operating system. OpenComal is very much platform independent, but for 18 | each platform a special "glue" module must be written. I am currently 19 | doing most of my work and development on Linux, hence the Linux bias in 20 | OpenComal 0.2. I do have glue modules for MsDos (16 bit :-), SunOS, 21 | FreeBSD and HP-UX, but they are not distributed with this release 22 | because they need some work. 23 | 24 | The OpenComal package is covered by the GNU General Public License. 25 | You can find a copy of that license in the doc/LICENSE file. 26 | 27 | For more potential interesting information on OpenComal, please check 28 | out my OpenComal page at http://www.josvisser.nl/opencomal. 29 | 30 | After reading this README, why not read: 31 | 32 | doc/QUICKSTART 33 | doc/BUILD 34 | doc/OpenComal.txt 35 | 36 | Thanks again for your interest. 37 | 38 | Jos Visser 39 | -------------------------------------------------------------------------------- /bin/Makefile: -------------------------------------------------------------------------------- 1 | .POSIX: 2 | .DELETE_ON_ERROR: 3 | 4 | .PHONY: install 5 | install: 6 | strip opencomal opencomalrun 7 | ../build/install opencomal -d $(PREFIX)/bin 8 | ../build/install opencomalrun -d $(PREFIX)/bin 9 | cp en.cat opencomal.cat 10 | ifeq ($(OPSYS),macos) 11 | ../build/install opencomal.cat -d $(PREFIX)/locale/en_GB.UTF-8 12 | cp ga.cat opencomal_ga.cat 13 | ../build/install opencomal_ga.cat -d $(PREFIX)/locale/en_GB.UTF-8 14 | $(RM) opencomal_ga.cat 15 | else 16 | ../build/install opencomal.cat -d $(PREFIX)/locale/en_IE.utf8 17 | cp ga.cat opencomal.cat 18 | ../build/install opencomal.cat -d $(PREFIX)/locale/ga_IE.utf8 19 | endif 20 | $(RM) opencomal.cat 21 | -------------------------------------------------------------------------------- /bin/README.md: -------------------------------------------------------------------------------- 1 | Here thou will hopefully sometime in the future once again findst pre-built OpenComal executables for the following 2 | platforms: 3 | 4 | - Linux (including the subsystem on Windows) 5 | - opencomal 6 | - opencomalrun 7 | 8 | - macOS 9 | - opencomal.macos 10 | - opencomalrun.macos 11 | 12 | Share and enjoy! 13 | 14 | Wed Sep 18 17:34:30 CEST 2002 15 | 16 | 17 | -------------------------------------------------------------------------------- /build/ccd-gcc: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # CCDEPS-GCC (C) 2002 Emile van Bergen. Distribution of this file is allowed 4 | # under the conditions detailed in the GNU General Public License (GPL). See 5 | # the file COPYING for more information. 6 | # 7 | # This script compiles and/or links one or more source or object files into a 8 | # object file or executable target, and outputs all extra dependencies found 9 | # while doing so in a file named target.d, which can be used by GNU Make. 10 | # 11 | # The script should be invoked the same way as your C compiler, that is, 12 | # specifying the target using a -o option and the source or object files as 13 | # non-option arguments. It will generate dependencies in the form 14 | # 15 | # target target.d: dir/file1.c dir/file2.c header1.h header2.h 16 | # dir/file1.c dir/file2.c header1.h header2.h: 17 | # 18 | # This version is intended for GCC, which can do compilation and dependency 19 | # generation in one step. The name of the GCC version (default gcc) can be 20 | # overridden using the CC environment variable. 21 | # 22 | # CHANGELOG 23 | # 24 | # 2003/1/8: EvB: adapted for gcc 3.2, still handles 2.95 as well. 25 | # 26 | # This was necessary because gcc 3.2 handles -MD differently than gcc 2.95: 27 | # where the old version generated a .d file for each source, in the current 28 | # directory, the new one does almost completely what this script intended to 29 | # do: generate one .d file in the same directory and with the same file name 30 | # as the target. 31 | # 32 | # The only fixups 3.2's .d files still need are: 33 | # 34 | # - changing the file name; gcc 3.2 strips the suffix of the target before 35 | # appending the .d, so targets x and x.o will both produce x.d, which is 36 | # not what we want; 37 | # 38 | # - adding the implicit dependencies as prerequisiteless targets, so that 39 | # make will just consider the target out of date if one does not exist 40 | # anymore; 41 | # 42 | # - adding the .d file as depending on the same prerequisites as our real 43 | # target so that it will be considered out of date if one of the files 44 | # mentioned in it are updated or missing. 45 | # 46 | # Basically, this version does all that by simply including the file 47 | # .d file in the list of .d files we look for. We may end 48 | # up generating the same file name, but that already was handled correctly. 49 | # Otherwise we perform the normal routine, so that we /know/ the targets will 50 | # be correct, directories and all, regardless of variations in gcc behaviour. 51 | 52 | cmdline="$*" 53 | 54 | while [ x"$1" != x ] 55 | do 56 | case "$1" in 57 | -o) tgt="$2" ; shift ;; # target specifier option 58 | -x|-u|-b|-V) shift ;; # options with arg after space 59 | -*) ;; # standard options 60 | *) fil="$fil $1" ;; # source or object files 61 | esac 62 | shift 63 | done 64 | 65 | CC="$REALCC" 66 | if [ x"$CC" = x ] 67 | then 68 | CC=gcc 69 | export CC 70 | fi 71 | 72 | # If we're not processing any .c files (link only), run gcc as-is and we're done 73 | 74 | expr "$fil" : ".*\.c" >/dev/null || exec $CC $cmdline 75 | 76 | # Otherwise, run the gcc with the -MD option, which generates a .d file 77 | # in the current directory for each .c or .cc source file processed. 78 | # 79 | # These files are post-processed (replacing the incorrectly named target 80 | # with the real target specified with -o, and adding the .d file), concatenated 81 | # into one .d file that is named based on the target name, and put in the 82 | # correct directory. Further, all prerequisites are added as bare targets, 83 | # preventing errors when files are missing due to renaming or restructuring 84 | # headers, but causing the files dependent on them to be considered out of 85 | # date. (GNU Make feature). 86 | # 87 | # Makefiles must include the .d files like this: -include $(OBJS_$(d):.o=.d) 88 | # or, when compiling and linking in one step: -include $(TGTS_$(d):%=%.d) 89 | 90 | dep=$tgt.d 91 | rm -f $dep 92 | 93 | $CC -MD $cmdline 94 | res=$? 95 | 96 | dgcc3=`echo $tgt | sed -e 's/\.[^.]*$//'`.d 97 | dgcc=`echo $fil | sed -e 's/[^ ]*\.[^c]//' -e 's/\.c/\.d/g' -e 's%.*/%%g'` 98 | 99 | for tf in $dgcc3 $dgcc 100 | do 101 | if [ -f $tf ] && mv $tf $dep.tmp 102 | then 103 | sed -e "s%.*:%$tgt $dep:%" < $dep.tmp >> $dep 104 | sed -e 's%^.*:%%' -e 's%^ *%%' -e 's% *\\$%%' -e 's%$%:%' \ 105 | < $dep.tmp >> $dep 106 | rm -f $dep.tmp 107 | found=1 108 | fi 109 | done 110 | 111 | [ x"$found" = x"1" ] && exit $res 112 | 113 | echo ERROR: $0: Cannot find any compiler-generated dependency files\! 114 | exit 1 115 | 116 | -------------------------------------------------------------------------------- /contrib/README: -------------------------------------------------------------------------------- 1 | ---------------------------------- 2 | OpenComal contributed source files 3 | ---------------------------------- 4 | 5 | I am: Jos Visser 6 | Date: Sun Sep 8 22:46:26 CEST 2002 7 | 8 | This directory contains a number of source files that contain the 9 | platform dependent sys_ routines for a number of platforms. They 10 | are out of date a bit and need some work. But, they should 11 | suffice to give you an idea about what is going on.... 12 | -------------------------------------------------------------------------------- /contrib/pdcfreeb.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /* 12 | * PDComal header file for FreeBSD 13 | */ 14 | 15 | #define HUGE_POINTER /* no need for this in real OS's */ 16 | #define O_BINARY 0 17 | 18 | #define HOST_OS "FreeBSD" 19 | #define VERSION "0.1" 20 | #define CLI "" /* Command Line Interpreter */ 21 | 22 | #define UNIX 23 | #define FREEBSD 24 | #define FLEX 25 | 26 | #define yywrap() 1 27 | #include 28 | -------------------------------------------------------------------------------- /contrib/pdcsun.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | -------------------------------------------------------------------------------- /hooks/pre-commit: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # Check that the code follows a consistent code style 4 | # 5 | 6 | # Check for existence of indent, and error out if not present. 7 | # On some *bsd systems the binary seems to be called gnunindent, 8 | # so check for that first. 9 | 10 | version=`gnuindent --version 2>/dev/null` 11 | if test "x$version" = "x"; then 12 | version=`gindent --version 2>/dev/null` 13 | if test "x$version" = "x"; then 14 | version=`indent --version 2>/dev/null` 15 | if test "x$version" = "x"; then 16 | echo "OpenCOMAL git pre-commit hook:" 17 | echo "Did not find GNU indent, please install it before continuing." 18 | exit 1 19 | else 20 | INDENT=indent 21 | fi 22 | else 23 | INDENT=gindent 24 | fi 25 | else 26 | INDENT=gnuindent 27 | fi 28 | 29 | case `$INDENT --version` in 30 | GNU*) 31 | ;; 32 | default) 33 | echo "OpenCOMAL git pre-commit hook:" 34 | echo "Did not find GNU indent, please install it before continuing." 35 | echo "(Found $INDENT, but it doesn't seem to be GNU indent)" 36 | exit 1 37 | ;; 38 | esac 39 | 40 | INDENT_PARAMETERS="--original \ 41 | --no-tabs \ 42 | --ignore-profile" 43 | 44 | echo "--Checking style--" 45 | for file in `git diff-index --cached --name-only HEAD --diff-filter=ACMR| grep "\.c$"` ; do 46 | # nf is the temporary checkout. This makes sure we check against the 47 | # revision in the index (and not the checked out version). 48 | nf=`git checkout-index --temp ${file} | cut -f 1` 49 | newfile=`mktemp /tmp/${nf}.XXXXXX` || exit 1 50 | $INDENT ${INDENT_PARAMETERS} \ 51 | $nf -o $newfile 2>> /dev/null 52 | # FIXME: Call indent twice as it tends to do line-breaks 53 | # different for every second call. 54 | $INDENT ${INDENT_PARAMETERS} \ 55 | $newfile 2>> /dev/null 56 | diff -u -p "${nf}" "${newfile}" 57 | r=$? 58 | rm "${newfile}" 59 | rm "${nf}" 60 | if [ $r != 0 ] ; then 61 | echo "=================================================================================================" 62 | echo " Code style error in: $file " 63 | echo " " 64 | echo " Please fix before committing. Don't forget to run git add before trying to commit again. " 65 | echo " If the whole file is to be committed, this should work (run from the top-level directory): " 66 | echo " " 67 | echo " cml-indent $file; git add $file; git commit" 68 | echo " " 69 | echo "=================================================================================================" 70 | exit 1 71 | fi 72 | done 73 | echo "--Checking style pass--" 74 | -------------------------------------------------------------------------------- /samples/README.md: -------------------------------------------------------------------------------- 1 | # OpenComal Samples 2 | 3 | This directory contains a bunch of OpenComal samples. They are all in 4 | "LIST" format (ASCII file format), which means that they must be ENTERed 5 | instead of LOADed. E.g.: 6 | 7 | $ NEW 8 | $ ENTER "verbaal.lst" 9 | 10 | (That particular program generates the Dutch textual representation of 11 | a number). There are also a lot of programs that test specific OpenComal 12 | functions and statements... 13 | 14 | Another interesting one is "slpl.lst", which is an interpreter (in OpenComal) 15 | for a simple list oriented programming language not completely unlike LISP. 16 | 17 | The examples/ directory contains some general example programs. The one doing 18 | decompression calculations is seriously broken, so please do not dive using 19 | the program's output as a guideline!!!!!!! 20 | 21 | The tests/ directory contains programs that test all OpenComal's statements 22 | and functions. To do a quick test of everything, follow this procedure: 23 | 24 | - enter "lst2sq.lst" 25 | - save "lst2sq.sq" 26 | - run 27 | (this enters and saves each program) 28 | - new 29 | - load "gentest.sq" 30 | - run 31 | 32 | The autorep and truefalse programs in the examples directory appears 33 | courtesy of Dick Klingens. 34 | 35 | Share and Enjoy! 36 | 37 | ++Jos.nl 38 | -------------------------------------------------------------------------------- /samples/examples/autorep.lst: -------------------------------------------------------------------------------- 1 | 10 //AUTOREP - a selfreproducing program ------------ 2 | 20 line:=21 3 | 30 DIM a$(line) OF 50, quote$ OF 2 4 | 40 pre:=4; after:=5; quote$:="""" 5 | 50 a$(1):="//AUTOREP - a selfreproducing program ------------" 6 | 60 a$(2):="line:=21 " 7 | 70 a$(3):="DIM a$(line) OF %), quote$ OF 2 " 8 | 80 a$(4):="pre:=4; after:=5; quote$:="""""""" " 9 | 90 a$(5):="FOR t:=1 TO pre DO " 10 | 100 a$(6):=" PRINT a$(t) " 11 | 110 a$(7):="ENDFOR t " 12 | 120 a$(8):="FOR t:=1 TO line DO " 13 | 130 a$(9):=" PRINT ""a$("",t,""):=""; quote$ " 14 | 140 a$(10):=" FOR i:=1 TO 50 DO " 15 | 150 a$(11):=" IF a$(t)(i:i)=quote$ THEN " 16 | 160 a$(12):=" PRINT quote$,quote$, " 17 | 170 a$(13):=" ELSE " 18 | 180 a$(14):=" PRINT a$(t)(i:i), " 19 | 190 a$(15):=" ENDIF " 20 | 200 a$(16):=" ENDFOR i " 21 | 210 a$(17):=" PRINT quote$ " 22 | 220 a$(18):="ENDFOR t " 23 | 230 a$(19):="FOR t:=after TO line " 24 | 240 a$(20):=" PRINT a$(t) " 25 | 250 a$(21):="ENDFOR t " 26 | 260 FOR t:=1 TO pre DO 27 | 270 PRINT a$(t) 28 | 280 ENDFOR t 29 | 290 FOR t:=1 TO line DO 30 | 300 PRINT "a$(",t,"):=";quote$; 31 | 310 FOR i:=1 TO 50 DO 32 | 320 IF a$(t)(i:i)=quote$ THEN 33 | 330 PRINT quote$,quote$, 34 | 340 ELSE 35 | 350 PRINT a$(t)(i:i), 36 | 360 ENDIF 37 | 370 ENDFOR i 38 | 380 PRINT quote$ 39 | 390 ENDFOR t 40 | 400 FOR t:=after TO line DO 41 | 410 PRINT a$(t) 42 | 420 ENDFOR t 43 | -------------------------------------------------------------------------------- /samples/examples/awaytofile1.lst: -------------------------------------------------------------------------------- 1 | 10 // "A Way to File" Demo. 2 | 20 // This program sets up the input data file and should chain to 'awaytofile2.lst' 3 | 30 // to process it. 4 | 33 5 | 36 TRAP 6 | 40 DELETE "mydatafile.dat" 7 | 43 ENDTRAP 8 | 46 9 | 50 OPEN FILE 1, "mydatafile.dat", WRITE 10 | 60 PRINT FILE 1: 0 11 | 70 READ surname$ 12 | 80 rec_count#:=0 13 | 90 WHILE surname$<>"***" DO 14 | 100 READ firstname$, job$, phone$ 15 | 110 PRINT FILE 1: surname$,firstname$,job$,phone$ 16 | 120 rec_count#:+1 17 | 130 READ surname$ 18 | 140 ENDWHILE 19 | 150 CLOSE FILE 1 20 | 160 OPEN FILE 1, "mydatafile.dat", RANDOM 9 21 | 170 PRINT FILE 1,1: rec_count# 22 | 180 CLOSE FILE 1 23 | 190 awaytofile2 24 | 200 PROC awaytofile2 EXTERNAL "awaytofile2.cml" 25 | 210 26 | 220 // ============================================================== 27 | 230 28 | 240 DATA "Fillmore", "Millard", "president", "NO PHONE" 29 | 250 DATA "Lincoln", "Abraham", "president", "NO PHONE" 30 | 260 DATA "Bronte", "Emily", "writer", "NO PHONE" 31 | 270 DATA "Rather", "Dan", "newscaster", "555-9876" 32 | 280 DATA "Fitzgerald", "Ella", "singer", "555-6789" 33 | 290 DATA "Savitch", "Jessica", "newscaster", "555-9653" 34 | 300 DATA "Mc Cartney", "Paul", "songwriter", "555-1212" 35 | 310 DATA "Washington", "George", "president", "NO PHONE" 36 | 320 DATA "Reynolds", "Frank", "newscaster", "555-8765" 37 | 330 DATA "Sills", "Beverley", "opera star", "555-9876" 38 | 340 DATA "Ford", "Henry", "capitalist", "NO PHONE" 39 | 350 DATA "Dewhurst", "Coleen", "actress", "555-9876" 40 | 360 DATA "Wonder", "Stevie", "songwriter", "555-0097" 41 | 370 DATA "Fuller", "Buckminster", "world architect", "555-7604" 42 | 380 DATA "Rawles", "John", "philosopher", "555-9702" 43 | 390 DATA "Trudeau", "Garry", "cartoonist", "555-9832" 44 | 400 DATA "Van Buren", "Abigail", "columnist", "555-8743" 45 | 410 DATA "Abzug", "Bella", "politician", "555-4443" 46 | 420 DATA "Thompson", "Hunter S.", "gonzo journalist", "555-9854" 47 | 430 DATA "Sinatra", "Frank", "singer", "555-9412" 48 | 440 DATA "Jabbar", "Kareem Abdul", "basketball player", "555-4439" 49 | 450 DATA "Mc Gee", "Travis", "fictitious detective", "555-8887" 50 | 460 DATA "Didion", "Joan ", "writer", "555-0009" 51 | 470 DATA "Frazetta", "Frank", "artist", "555-9991" 52 | 480 DATA "Henson", "Jim", "puppeteer", "555-0001" 53 | 490 DATA "Sagan", "Carl", "astronomer", "555-7070" 54 | 500 DATA "***" 55 | -------------------------------------------------------------------------------- /samples/examples/awaytofile2.lst: -------------------------------------------------------------------------------- 1 | 10 // "A Way to File" Demo. 2 | 20 // Ported from Forth code by Doug Hoffman, apparently in turn derived from 3 | 30 // Brodie. 4 | 40 // NB: This PROC is designed to be EXECed from 'awaytofile1.lst'. 5 | 50 // 6 | 60 // It's interesting how parallel, fixed-length arrays can do most of the 7 | 70 // things other langauges use tuples, lists and a heap for. trees1.lst 8 | 80 // teaches a similar lesson. 9 | 90 10 | 100 PROC awaytofile2 CLOSED 11 | 110 rec_count#:=0 12 | 120 max_recs#:=256 13 | 130 curr_rec#:=0 14 | 140 kind$:="" 15 | 150 what$:="" 16 | 160 DIM surnames$(max_recs#), givens$(max_recs#), jobs$(max_recs#), phones$(max_recs#) 17 | 170 my_open("mydatafile.dat") 18 | 180 my_print 19 | 190 find("job", "news") 20 | 200 get("job") 21 | 210 all 22 | 220 23 | 230 // Open the named file and read all records into memory 24 | 240 PROC my_open(file$) CLOSED 25 | 250 IMPORT rec_count#, surnames$(), givens$(), jobs$(), phones$() 26 | 260 TRAP 27 | 270 OPEN FILE 1, file$, READ 28 | 280 INPUT FILE 1: rec_count# 29 | 290 FOR n#:=1 TO rec_count# DO 30 | 300 INPUT FILE 1: surnames$(n#), givens$(n#), jobs$(n#), phones$(n#) 31 | 310 ENDFOR 32 | 320 CLOSE FILE 1 33 | 330 HANDLER 34 | 340 PRINT "File '";file$;"' not found" 35 | 350 ENDTRAP 36 | 360 ENDPROC 37 | 370 38 | 380 // Print the contents of all records and fields 39 | 390 PROC my_print CLOSED 40 | 400 IMPORT rec_count#, surnames$(), givens$(), jobs$(), phones$() 41 | 410 FOR n#:=1 TO rec_count# DO 42 | 420 PRINT surnames$(n#);",";givens$(n#);",";jobs$(n#);",";phones$(n#) 43 | 430 ENDFOR 44 | 440 ENDPROC 45 | 450 46 | 460 // Find the record in which there is a match between the contents of the 47 | 470 // given field and the given string 48 | 480 PROC find(field$, string$) 49 | 490 curr_rec#:=0 50 | 500 kind$:=field$ 51 | 510 what$:=string$ 52 | 520 find_internal(field$, string$, TRUE) 53 | 530 ENDPROC 54 | 540 55 | 550 PROC find_internal(field$, string$, first_only#) 56 | 560 CASE field$ OF 57 | 570 WHEN "surname" 58 | 580 find_kind(surnames$(), string$, first_only#) 59 | 590 WHEN "given" 60 | 600 find_kind(givens$(), string$, first_only#) 61 | 610 WHEN "job" 62 | 620 find_kind(jobs$(), string$, first_only#) 63 | 630 WHEN "phone" 64 | 640 find_kind(phones$(), string$, first_only#) 65 | 650 ENDCASE 66 | 660 ENDPROC 67 | 670 68 | 680 PROC find_kind(fields$(), string$, first_only#) 69 | 690 FOR curr_rec#:=1 TO rec_count# DO 70 | 700 IF string$ IN fields$(curr_rec#) THEN 71 | 710 print_name(curr_rec#) 72 | 720 IF first_only# THEN 73 | 730 RETURN 74 | 740 ENDIF 75 | 750 ENDIF 76 | 760 ENDFOR 77 | 770 ENDPROC 78 | 780 79 | 790 PROC print_name(record#) 80 | 800 PRINT givens$(record#);" ";surnames$(record#) 81 | 810 ENDPROC 82 | 820 83 | 830 // Prints the contents of the given type of field from the current record 84 | 840 PROC get(field$) 85 | 850 CASE field$ OF 86 | 860 WHEN "surname" 87 | 870 PRINT surnames$(curr_rec#) 88 | 880 WHEN "given" 89 | 890 PRINT givens$(curr_rec#) 90 | 900 WHEN "job" 91 | 910 PRINT jobs$(curr_rec#) 92 | 920 WHEN "phone" 93 | 930 PRINT phones$(curr_rec#) 94 | 940 ENDCASE 95 | 950 ENDPROC 96 | 960 97 | 970 // Beginning at the top of the file, use kind$ to determine type of field 98 | 980 // and find all matches on what$ 99 | 990 PROC all 100 | 1000 find_internal(kind$, what$, FALSE) 101 | 1010 ENDPROC 102 | 1020 ENDPROC 103 | -------------------------------------------------------------------------------- /samples/examples/computer.lst: -------------------------------------------------------------------------------- 1 | 9000 MODULE computer 2 | 9010 EXPORT computer'comal 3 | 9020 EXPORT opencomal 4 | 9030 EXPORT computer'eol$ 5 | 9040 EXPORT computer'drive$ 6 | 9050 EXPORT computer'rvson 7 | 9060 EXPORT computer'rvsoff 8 | 9070 EXPORT computer'screen$ 9 | 9080 // 10 | 9090 FUNC opencomal CLOSED 11 | 9100 RETURN 5 12 | 9110 ENDFUNC opencomal 13 | 9120 // 14 | 9130 FUNC computer'comal CLOSED 15 | 9140 RETURN opencomal 16 | 9150 ENDFUNC computer'comal 17 | 9160 // 18 | 9170 FUNC computer'eol$ CLOSED 19 | 9180 RETURN CHR$(10) 20 | 9190 ENDFUNC computer'eol$ 21 | 9200 // 22 | 9210 FUNC computer'drive$(x) CLOSED 23 | 9220 RETURN "C:" 24 | 9230 ENDFUNC computer'drive$ 25 | 9240 // 26 | 9250 PROC computer'rvson CLOSED 27 | 9260 SYS rvson 28 | 9270 ENDPROC computer'rvson 29 | 9280 // 30 | 9290 PROC computer'rvsoff CLOSED 31 | 9300 SYS rvsoff 32 | 9310 ENDPROC computer'rvsoff 33 | 9320 // 34 | 9330 FUNC computer'screen$ CLOSED 35 | 9340 RETURN "DS:" 36 | 9350 ENDFUNC computer'screen$ 37 | 9360 ENDMODULE computer 38 | -------------------------------------------------------------------------------- /samples/examples/computer.md: -------------------------------------------------------------------------------- 1 | These PROCs and FUNCS were originally specified in 2 | [COMAL Today issue 26](https://archive.org/download/COMAL_Today_Issue_26), 3 | pages 33-34. 4 | 5 | *COMPUTER'COMAL*: returns a number that identifies what COMAL is running. 5 is OpenCOMAL. 6 | 7 | *OPENCOMAL*: returns 5. 8 | 9 | *COMPUTER'DRIVE$(x)*: returns drives that are safe to use, at least for x = 0 and 1. 10 | 11 | *COMPUTER'SCREEN$*: returns the name for the screen, for use with the SELECT statement. 12 | 13 | *COMPUTER'RVSON*: turns on reverse video in PRINT statements. 14 | 15 | *COMPUTER'RVSOFF*: turns off reverse video in PRINT statements. 16 | 17 | *COMPUTER'EOL$*: returns the proper EOL character(s). 18 | -------------------------------------------------------------------------------- /samples/examples/deco.lst: -------------------------------------------------------------------------------- 1 | 10 // General demonstration program for US-NAVY like decompression 2 | 20 // calculations to be used for divers 3 | 30 // 4 | 40 PAGE 5 | 50 PRINT "US Navy decompressiemodel" 6 | 60 PRINT 7 | 70 // 8 | 80 READ aantalweefsels 9 | 90 DIM halfwaarde(aantalweefsels), pweefsel(aantalweefsels) 10 | 100 FOR f:=1 TO aantalweefsels DO READ halfwaarde(f) 11 | 110 // 12 | 120 DATA 6 // aantal weefsels 13 | 130 DATA 5, 10, 20, 40, 80, 120 // halfwaardetijden per weefsel 14 | 140 // 15 | 150 INPUT "Luchtdruk op waterniveau (in bar) : ": luchtdruk 16 | 160 INPUT "Soortelijk gewicht van water (kg/l) : ": sgh2o 17 | 170 pn2:=0.8*luchtdruk // partiele stikstofdruk op 0m diepte 18 | 180 dt:=1/60 // delta t van 1 seconde 19 | 190 PRINT 20 | 200 PRINT "De partiele stikstofdruk op 0 meter is ";pn2;" bar" 21 | 210 PRINT 22 | 220 // 23 | 230 pweefsel:=pn2 // initiele stikstofdruk in elk weefsel 24 | 240 diepte:=0 25 | 250 // 26 | 260 REPEAT 27 | 270 PRINT 28 | 280 PRINT "Diepte is ";diepte;" meter" 29 | 290 REPEAT 30 | 300 INPUT "Nieuwe diepte (in meter) : ": nd 31 | 310 IF nd<0 THEN PRINT "Fout, nieuwe diepte moet >= 0 zijn" 32 | 320 UNTIL nd>=0 33 | 330 IF nd=diepte THEN 34 | 340 REPEAT 35 | 350 INPUT "Tijd op deze diepte (in min) : ": tijd 36 | 360 IF tijd<0 THEN PRINT "Fout, tijd moet >=0 zijn" 37 | 370 UNTIL tijd>=0 38 | 380 ELSE 39 | 390 REPEAT 40 | 400 INPUT "Stijg/daal snelheid (in m/min) : ": snelheid 41 | 410 IF snelheid<0 THEN PRINT "Fout, snelheid moet >=0 zijn" 42 | 420 UNTIL snelheid>=0 43 | 430 IF snelheid=0 THEN 44 | 440 tijd:=0 45 | 450 PRINT "Tijdloze afdaling/opstijging" 46 | 460 ELSE 47 | 470 tijd:=ABS(diepte-nd)/snelheid 48 | 480 PRINT "Afdaling/opstijging duurt "; 49 | 490 PRINT USING "##.###": tijd; 50 | 500 PRINT " minuten" 51 | 510 ENDIF 52 | 520 ENDIF 53 | 530 // 54 | 540 IF tijd>0 THEN 55 | 550 stap:=SGN(nd-diepte) 56 | 560 IF stap=0 THEN 57 | 570 calc'weefsel(diepte, tijd) 58 | 580 ELSE 59 | 590 z:=tijd/dt 60 | 600 FOR f:=1 TO aantalweefsels DO 61 | 610 pweefsel(f):=pweefsel(f)+stap*((dt*snelheid)/10)*(1-0.5^(dt/halfwaarde(f))) 62 | 620 ENDFOR 63 | 630 ENDIF 64 | 640 ENDIF 65 | 650 diepte:=nd 66 | 660 PRINT 67 | 670 print'weefsels("Partiele stikstofdrukken") 68 | 680 UNTIL diepte=0 69 | 690 // 70 | 700 PROC calc'weefsel(diepte, min) CLOSED 71 | 710 IMPORT pweefsel(), halfwaarde(), pn2, luchtdruk, sgh2o 72 | 720 IMPORT aantalweefsels 73 | 730 // 74 | 740 pn2d:=0.8*(luchtdruk+sgh2o*diepte/10) // part. n2 druk op diepte 75 | 750 // 76 | 760 FOR f:=1 TO aantalweefsels DO 77 | 770 n:=min/halfwaarde(f) // aantal verstreken halfwaardeperiodes 78 | 780 gd:=1-0.5^n // gecompenseerd drukverschil factor 79 | 790 drukverschil:=pn2d-pweefsel(f) 80 | 800 pweefsel(f):=pweefsel(f)+gd*drukverschil 81 | 810 ENDFOR 82 | 820 ENDPROC 83 | 830 // 84 | 840 PROC print'weefsels(title$) CLOSED 85 | 850 IMPORT aantalweefsels, halfwaarde(), pweefsel() 86 | 860 PRINT title$ 87 | 870 PRINT 88 | 880 // 89 | 890 FOR f:=1 TO aantalweefsels DO 90 | 900 PRINT "Weefsel ";f;" ("; 91 | 910 PRINT USING "###": halfwaarde(f); 92 | 920 PRINT " min) = "; 93 | 930 PRINT USING "##.###": pweefsel(f); 94 | 940 PRINT " bar" 95 | 950 ENDFOR 96 | 960 ENDPROC 97 | -------------------------------------------------------------------------------- /samples/examples/gtk_server.lst: -------------------------------------------------------------------------------- 1 | 9000 MODULE gtk_server 2 | 9010 EXPORT gtk$ 3 | 9020 EXPORT gtk_init 4 | 9030 EXPORT toplevel$ 5 | 9040 EXPORT connect 6 | 9050 EXPORT callback$ 7 | 9060 EXPORT gtk_exit 8 | 9070 _$:="" 9 | 9080 FUNC gtk$(arg$) CLOSED 10 | 9090 f#:=FREEFILE 11 | 9100 OPEN FILE f#, "/tmp/comal", APPEND 12 | 9110 PRINT FILE f#: arg$ 13 | 9120 CLOSE FILE f# 14 | 9130 f#:=FREEFILE 15 | 9140 OPEN FILE f#, "/tmp/comal", READ 16 | 9150 INPUT FILE f#: response$ 17 | 9160 CLOSE FILE f# 18 | 9170 RETURN response$ 19 | 9180 ENDFUNC 20 | 9190 PROC gtk_init CLOSED 21 | 9200 PASS "gtk-server -fifo=/tmp/comal -detach" 22 | 9210 ENDPROC 23 | 9220 FUNC toplevel$ CLOSED 24 | 9230 RETURN gtk$("gtk_server_toplevel") 25 | 9240 ENDFUNC 26 | 9250 PROC connect(widget$, name$) CLOSED 27 | 9260 _$:=gtk$("gtk_server_connect "+widget$+" XmNactivateCallback "+name$) 28 | 9270 ENDPROC 29 | 9280 FUNC callback$ CLOSED 30 | 9290 RETURN gtk$("gtk_server_callback wait") 31 | 9300 ENDFUNC 32 | 9310 PROC gtk_exit CLOSED 33 | 9320 _$:=gtk$("gtk_server_exit") 34 | 9330 ENDPROC 35 | 9340 ENDMODULE 36 | -------------------------------------------------------------------------------- /samples/examples/hex.lst: -------------------------------------------------------------------------------- 1 | 10 // A function for converting a number to hex 2 | 20 FUNC hex$(n#) CLOSED 3 | 30 FUNC hexdigit$(n#) 4 | 40 RETURN "0123456789ABCDEF"(n#+1:n#+1) 5 | 50 ENDFUNC hexdigit$ 6 | 60 // 7 | 70 IF n#<16 THEN RETURN hexdigit$(n#) 8 | 80 RETURN hex$(n# DIV 16)+hexdigit$(n# MOD 16) 9 | 90 ENDFUNC hex$ 10 | -------------------------------------------------------------------------------- /samples/examples/mbutton.lst: -------------------------------------------------------------------------------- 1 | 5 // You should add "STR_NAME = XmNtitle, title" to gtk-server.cfg for this 2 | 10 USE gtk_server 3 | 20 gtk_init 4 | 30 top$:=toplevel$ 5 | 40 _$:=gtk$("XtVaSetValues "+top$+" s:XmNtitle s:Test1 NULL") 6 | 50 bboard$:=gtk$("XtVaCreateManagedWidget bboard xmBulletinBoardWidgetClass "+top$+" s:XmNresizePolicy e:XmRESIZE_NONE s:XmNheight h:150 s:XmNwidth h:250 s:XmNbackground e:SkyBlue NULL") 7 | 60 button$:=gtk$(" XtVaCreateManagedWidget 'Push here' xmPushButtonWidgetClass "+bboard$+" s:XmNbackground e:Goldenrod s:XmNforeground e:MidnightBlue s:XmNheight h:30 s:XmNwidth h:100 s:XmNx h:75 s:XmNy h:60 s:XmNshadowThickness h:3 NULL") 8 | 70 connect(button$, "activateCB") 9 | 80 event_loop 10 | 90 PRINT "Pushbutton activated; normal termination." 11 | 100 gtk_exit 12 | 110 PROC event_loop CLOSED 13 | 120 REPEAT 14 | 130 event$:=callback$ 15 | 140 UNTIL event$="activateCB" 16 | 150 ENDPROC 17 | 160 MODULE gtk_server 18 | 170 EXPORT gtk$ 19 | 180 EXPORT gtk_init 20 | 190 EXPORT toplevel$ 21 | 200 EXPORT connect 22 | 210 EXPORT callback$ 23 | 220 EXPORT gtk_exit 24 | 230 _$:="" 25 | 240 FUNC gtk$(arg$) CLOSED 26 | 250 f#:=FREEFILE 27 | 260 OPEN FILE f#, "/tmp/comal", APPEND 28 | 270 PRINT FILE f#: arg$ 29 | 280 CLOSE FILE f# 30 | 290 f#:=FREEFILE 31 | 300 OPEN FILE f#, "/tmp/comal", READ 32 | 310 INPUT FILE f#: response$ 33 | 320 CLOSE FILE f# 34 | 330 RETURN response$ 35 | 340 ENDFUNC 36 | 350 PROC gtk_init CLOSED 37 | 360 PASS "gtk-server -fifo=/tmp/comal -detach" 38 | 370 ENDPROC 39 | 380 FUNC toplevel$ CLOSED 40 | 390 RETURN gtk$("gtk_server_toplevel") 41 | 400 ENDFUNC 42 | 410 PROC connect(widget$, name$) CLOSED 43 | 420 _$:=gtk$("gtk_server_connect "+widget$+" XmNactivateCallback "+name$) 44 | 430 ENDPROC 45 | 440 FUNC callback$ CLOSED 46 | 450 RETURN gtk$("gtk_server_callback wait") 47 | 460 ENDFUNC 48 | 470 PROC gtk_exit CLOSED 49 | 480 _$:=gtk$("gtk_server_exit") 50 | 490 ENDPROC 51 | 500 ENDMODULE 52 | -------------------------------------------------------------------------------- /samples/examples/prime.lst: -------------------------------------------------------------------------------- 1 | 10 INPUT "A number please : ": n# 2 | 20 PRINT n#; 3 | 30 IF isprime#(n#) THEN 4 | 40 PRINT "is a prime number!" 5 | 50 ELSE 6 | 60 PRINT "is not a prime number..." 7 | 70 ENDIF 8 | 80 9 | 90 FUNC isprime#(n#) CLOSED 10 | 100 FOR f#:=2 TO n# DIV 2 DO 11 | 110 IF n# MOD f#=0 THEN RETURN 0 12 | 150 ENDFOR f# 13 | 160 RETURN 1 14 | 170 ENDFUNC isprime# 15 | -------------------------------------------------------------------------------- /samples/examples/slpl.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/poldy/OpenCOMAL/a4c4aa8641d4d8a30ef47de65e1a9b6b9a4f78ca/samples/examples/slpl.txt -------------------------------------------------------------------------------- /samples/examples/standard.md: -------------------------------------------------------------------------------- 1 | These PROCs and FUNCs were originally specified in 2 | [COMAL Today issue 27](https://archive.org/download/Comal_Today_Issue_27), 3 | pages 47-52. 4 | 5 | *VERSION'STANDARD$*: displays version and author information. 6 | 7 | *FILE'EXISTS(filename$)*: Checks if the specified file (or 8 | volume:path/file) exists and returns TRUE or FALSE. 9 | 10 | *TYPE(filename$)*: Similar to the Windows TYPE command. 11 | It gets characters from the specified file one by one and prints 12 | them. The text can be paused with the space bar and aborted with 13 | ESC. It first calls FILE'EXISTS, which eliminates the need for you 14 | to do so. 15 | 16 | *CLEARKEYS*: Clears all keys from the keyboard buffet so the next 17 | KEYS, INKEYS, INPUT does not unintentionally pick them up. 18 | 19 | *CLEARLINES(row1,row2)*: Clear all text between the specified lines, 20 | inclusive. 21 | 22 | *NUMBER(text$)*: Returns TRUE if the string passed to it contains 23 | a valid number. It can be used to prevent the VAL() function from 24 | causing an error. 25 | 26 | *GETKEY$*: First clears the keyboard buffer, then goes into a loop 27 | until a key is pressed. The key pressed is returned to the program. 28 | 29 | *GETVALIDKEY$(valid$)*: Clears the keyboard buffer, goes into a 30 | loop until a key from the string *valid$* is pressed, then returns 31 | that key to the program. 32 | 33 | *STRIPCHARS$(text$,char$)*: Removes all characters from the 34 | end of . 35 | 36 | *GETINFILE(REF infile$)*: Opens the file for input. If 37 | the file does not exist, the user is notified and prompted again 38 | for the filename. 39 | 40 | *GETOUTFILE(REF outfile$)*: Opens the file for writing. 41 | If the file already exists, the user is asked for permission to 42 | overwrite it or to enter another filename. 43 | 44 | *GETFILES(REF infile$,REF outfile$)*: Combines the above two PROCs. 45 | First asks for an input filename, then an output filename, and 46 | verifies that the names are not the same and warns the user if they 47 | are. 48 | 49 | *QUICKSORT(REF array$(),first,last)*: This is the familiar Quicksort 50 | PROC that has been published in COMAL today several times. It very 51 | quickly sorts an array of strings. The sort can be confined to a 52 | range of the array starting with element and ending with 53 | . 54 | 55 | *QUICKSORTNUM(REF array(),first,last)*: Like QUICKSORT, except this 56 | one sorts numeric arrays. The above PROC will correctly sort numeric 57 | arrays also if each number has the same number of digits. 58 | 59 | *WAITKEY*: Pauses the program, prints a message telling the user to press a key 60 | to continue, then erases the continue message and continues the program. 61 | 62 | *YES(prompt$)*: Used to get a YES or NO answer. For example: 63 | ``` 64 | IF yes("Quit now?") THEN END 65 | ``` 66 | It does not flash the cursor while awaiting input, but prints "YES" 67 | or "NO" at the current cursor position after the Y or N key is 68 | pressed. 69 | 70 | *CENTER(text$)*: Centers the string, on the current screen 71 | line. If more than 79 characters, the string is printed without 72 | centering. 73 | 74 | *CENTER'AT(row,text$)*: This PROC centers the string on row 75 | . If more than 79 characters, the string is printed without 76 | centering. 77 | -------------------------------------------------------------------------------- /samples/examples/trees1.lst: -------------------------------------------------------------------------------- 1 | 10 // Example program to create a binary tree and display 2 | 20 // its contents in alphabetical order of name. 3 | 30 // Ported from an example in Brandy BASIC. 4 | 40 5 | 50 DIM g_name$(100), g_value#(100), left#(100), right#(100) 6 | 60 next#:=1 7 | 70 root#:=0 8 | 80 FOR n#:=1 TO 10 DO 9 | 90 READ x$, x# 10 | 100 add(x$, x#) 11 | 110 ENDFOR 12 | 120 show(root#) 13 | 130 14 | 140 DATA "red", 5, "green", 10, "yellow", 15, "blue", 20, "black", 25, "white", 30 15 | 150 DATA "orange", 35, "pink", 40, "cyan", 45, "purple", 50 16 | 160 17 | 170 PROC add(name$, value#) 18 | 180 g_name$(next#):=name$ 19 | 190 g_value#(next#):=value# 20 | 200 left#(next#):=0 21 | 210 right#(next#):=0 22 | 220 IF root#=0 THEN 23 | 230 root#:=1 24 | 240 next#:=2 25 | 250 RETURN 26 | 260 ENDIF 27 | 270 p#:=root# 28 | 280 done#:=FALSE 29 | 290 REPEAT 30 | 300 IF name$0 THEN 32 | 320 p#:=left#(p#) 33 | 330 ELSE 34 | 340 left#(p#):=next# 35 | 350 done#:=TRUE 36 | 360 ENDIF 37 | 370 ELSE 38 | 380 IF right#(p#)<>0 THEN 39 | 390 p#:=right#(p#) 40 | 400 ELSE 41 | 410 right#(p#):=next# 42 | 420 done#:=TRUE 43 | 430 ENDIF 44 | 440 ENDIF 45 | 450 UNTIL done# 46 | 460 next#:+1 47 | 470 ENDPROC 48 | 480 49 | 490 PROC show(p#) 50 | 500 IF left#(p#)<>0 THEN show(left#(p#)) 51 | 510 PRINT g_name$(p#),TAB(20),g_value#(p#) 52 | 520 IF right#(p#)<>0 THEN show(right#(p#)) 53 | 530 ENDPROC 54 | -------------------------------------------------------------------------------- /samples/examples/truefalse.lst: -------------------------------------------------------------------------------- 1 | 10 // TRUE-FALSE sample program 2 | 20 3 | 30 DIM type$(FALSE:TRUE) OF 5 4 | 40 5 | 50 type$(FALSE):="false"; type$(TRUE):="true " 6 | 60 PRINT "AND CHART / OR CHART" 7 | 70 PRINT "--------------------" 8 | 80 FOR a:=FALSE TO TRUE DO 9 | 90 FOR b:=FALSE TO TRUE DO 10 | 100 PRINT "A = ",type$(a)," B = ",type$(b)," ", 11 | 110 PRINT "A and B = ",type$(a AND b)," ", 12 | 120 PRINT "A or B = ",type$(a OR b) 13 | 130 ENDFOR b 14 | 140 ENDFOR a 15 | -------------------------------------------------------------------------------- /samples/examples/verbaal_proc.lst: -------------------------------------------------------------------------------- 1 | 10 // External FUNC verbaal$ 2 | 20 // SAVE this as verbaal.cml and run verbaal_test 3 | 30 4 | 40 FUNC verbaal$(getal#) CLOSED 5 | 50 // 6 | 60 // ************************************ 7 | 70 // ** FUNC Verbaal$ ( Integer ) ** 8 | 80 // ************************************ 9 | 90 // 10 | 100 // Geschreven door Jos Visser, 25-06-1987 11 | 110 // Aangepast voor PDCOMAL, 10-9-92 12 | 120 // 13 | 130 // 14 | 140 // Functie : 15 | 150 // Deze functie neemt als parameter een integer getal, 16 | 160 // positief danwel negatief, en geeft een string terug 17 | 170 // die weergeeft hoe dat getal op zijn Nederlands 18 | 180 // geschreven kan worden. 19 | 190 // 20 | 200 // Parameters in : 21 | 210 // Integer getal 22 | 220 // 23 | 230 // Parameters uit : 24 | 240 // String, maximaal 132 karakters lang 25 | 250 // 26 | 260 // Packages ed. : 27 | 270 // Geen 28 | 280 // 29 | 290 PROC skipspaces(REF a$) CLOSED 30 | 300 IF a$<>"" THEN 31 | 310 WHILE a$(LEN(a$):LEN(a$))=" " DO a$:=a$(1:LEN(a$)-1) 32 | 320 ENDIF 33 | 330 ENDPROC 34 | 340 // 35 | 350 FUNC cijfer$(nr#) CLOSED 36 | 360 DIM a$ OF 5 37 | 370 a$:="nul een twee drie vier vijf zes zevenacht negentien "(1+nr#*5:5+nr#*5) 38 | 380 skipspaces(a$) 39 | 390 RETURN a$ 40 | 400 ENDFUNC 41 | 410 // 42 | 420 FUNC t'11'19$(nr#) CLOSED 43 | 430 DIM a$ OF 10 44 | 440 a$:="tien elf twaalf dertien veertien vijftien zestien zeventienachtien negentien"(1+(nr#-10)*9:9+(nr#-10)*9) 45 | 450 skipspaces(a$) 46 | 460 RETURN a$ 47 | 470 ENDFUNC 48 | 480 // 49 | 490 FUNC tiental$(nr#) CLOSED 50 | 500 DIM a$ OF 10 51 | 510 nr#:=nr# DIV 10 52 | 520 a$:="twintig dertig veertig vijftig zestig zeventigtachtig negentig"(1+(nr#-2)*8:8+(nr#-2)*8) 53 | 530 skipspaces(a$) 54 | 540 RETURN a$ 55 | 550 ENDFUNC 56 | 560 // 57 | 570 FUNC duizend$(nr#) CLOSED 58 | 580 honderd#:=nr# DIV 100 59 | 590 rest#:=nr# MOD 100 60 | 600 IF honderd#>1 THEN 61 | 610 result$:=cijfer$(honderd#)+"honderd" 62 | 620 ELIF honderd#=1 63 | 630 result$:="honderd" 64 | 640 ELSE 65 | 650 result$:="" 66 | 660 ENDIF 67 | 670 IF rest#<=10 THEN 68 | 680 IF rest#<>0 OR honderd#=0 THEN result$:+cijfer$(rest#) 69 | 690 ELIF rest#<20 70 | 700 result$:+t'11'19$(rest#) 71 | 710 ELSE 72 | 720 IF rest# MOD 10<>0 THEN result$:=result$+cijfer$(rest# MOD 10)+"en" 73 | 730 IF rest# DIV 10>0 THEN result$:+tiental$(rest#) 74 | 740 ENDIF 75 | 750 RETURN result$ 76 | 760 ENDFUNC 77 | 770 // 78 | 780 DIM result$ OF 132, subresult$ OF 40 79 | 790 result$:="" 80 | 800 IF getal#<0 THEN 81 | 810 negatief#:=TRUE 82 | 820 getal#:=-getal# 83 | 830 ELSE 84 | 840 result$:="" 85 | 850 negatief#:=FALSE 86 | 860 ENDIF 87 | 870 FOR macht#:=9 DOWNTO 0 STEP 3 DO 88 | 880 subgetal#:=getal# DIV 10^macht# 89 | 890 getal#:=getal# MOD 10^macht# 90 | 900 IF subgetal#>0 OR (macht#=0 AND result$="") THEN 91 | 910 subresult$:=duizend$(subgetal#) 92 | 920 IF macht#<>3 OR subgetal#<>1 THEN 93 | 930 result$:=result$+", "+subresult$ 94 | 940 ELSE 95 | 950 IF result$="" THEN result$:=" " 96 | 960 ENDIF 97 | 970 CASE macht# OF 98 | 980 WHEN 9 99 | 990 result$:+" miljard " 100 | 1000 WHEN 6 101 | 1010 result$:+" miljoen " 102 | 1020 WHEN 3 103 | 1030 result$:+"duizend " 104 | 1040 OTHERWISE 105 | 1050 NULL 106 | 1060 ENDCASE 107 | 1070 ENDIF 108 | 1080 skipspaces(result$) 109 | 1090 ENDFOR 110 | 1100 result$:=result$(3:) 111 | 1110 IF negatief# THEN result$:="min "+result$ 112 | 1120 RETURN result$ 113 | 1130 ENDFUNC 114 | 1140 // 115 | -------------------------------------------------------------------------------- /samples/examples/verbaal_test.lst: -------------------------------------------------------------------------------- 1 | 10 // General sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a# 5 | 50 PRINT a#;" ";verbaal$(a#) 6 | 60 ENDWHILE 7 | 70 // 8 | 80 DATA 1, 12, 34, 112, 1009, 1234567890 9 | 90 // 10 | 100 FUNC verbaal$(getal#) EXTERNAL "verbaal.cml" 11 | -------------------------------------------------------------------------------- /samples/tests/aap1.prl: -------------------------------------------------------------------------------- 1 | 10 // External PROCedure 2 | 20 // 3 | 30 PROC aap 4 | 40 aap:+1 5 | 50 PRINT "Inside aap" 6 | 60 ENDPROC 7 | -------------------------------------------------------------------------------- /samples/tests/aap3.prl: -------------------------------------------------------------------------------- 1 | 10 // olifant external PROCedure 2 | 20 // 3 | 30 PROC olifant 4 | 40 olifant:+1 5 | 50 tijger 6 | 60 ENDPROC 7 | -------------------------------------------------------------------------------- /samples/tests/abs()1.lst: -------------------------------------------------------------------------------- 1 | 10 // ABS() sample program 2 | 20 // 3 | 30 PRINT ABS(-4.5) 4 | 40 PRINT ABS(4.6) 5 | -------------------------------------------------------------------------------- /samples/tests/acs()1.lst: -------------------------------------------------------------------------------- 1 | 10 // ACS() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Please stand by for arc cosinus check" 5 | 50 FOR f:=-1 TO 1 STEP 0.010000 DO 6 | 60 CURSOR 4,1 7 | 70 PRINT USING "#.#####": f; 8 | 80 d:=ABS(f-COS(ACS(f))) 9 | 90 IF d>0.0000001 THEN STOP 10 | 100 ENDFOR 11 | 110 PRINT 12 | 120 PRINT "No abnormal differences encountered" 13 | -------------------------------------------------------------------------------- /samples/tests/append1.lst: -------------------------------------------------------------------------------- 1 | 10 // APPEND sample program 2 | 20 // 3 | 30 TRAP 4 | 40 DELETE "ofile6" 5 | 50 ENDTRAP 6 | 60 // 7 | 70 OPEN FILE 1, "ofile6", WRITE 8 | 80 schrijf 9 | 90 // 10 | 100 OPEN FILE 1, "ofile6", APPEND 11 | 110 schrijf 12 | 120 // 13 | 130 OPEN FILE 1, "ofile6", READ 14 | 140 WHILE NOT(EOF(1)) DO 15 | 150 READ FILE 1: a# 16 | 160 READ b# 17 | 170 IF a#<>b# THEN STOP 18 | 180 ENDWHILE 19 | 190 // 20 | 200 CLOSE 21 | 210 // 22 | 220 PRINT "All Ok" 23 | 230 // 24 | 240 PROC schrijf 25 | 250 FOR f#:=-5 TO 5 DO WRITE FILE 1: f# 26 | 260 CLOSE FILE 1 27 | 270 ENDPROC 28 | 280 // 29 | 290 DATA -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5, -5, -4, -3, -2, -1, 0, 1, 2, 3, 4, 5 30 | -------------------------------------------------------------------------------- /samples/tests/arr1.lst: -------------------------------------------------------------------------------- 1 | 10 // Simple array test 2 | 20 // 3 | 30 n#:=99 4 | 40 DIM a(100), b#(100), c$(10, 10), d(100), e#(100), f$(100) 5 | 50 a():=n# 6 | 60 check(a(), n#, TRUE) 7 | 70 check(a(), n#-1, FALSE) 8 | 80 a:=n#-2 9 | 90 check(a(), n#-2, FALSE) 10 | 100 TRAP 11 | 110 a():=b#() 12 | 120 error 13 | 130 HANDLER 14 | 140 NULL 15 | 150 ENDTRAP 16 | 160 d():=a() 17 | 170 check(d(), n#-2, FALSE) 18 | 180 b#():=42 19 | 190 e#():=b#() 20 | 200 check2(e#(), 42, TRUE) 21 | 210 check2(e#(), 42, FALSE) 22 | 220 c$():="OpenComal" 23 | 230 check3(c$(), "OpenComal", 2) 24 | 240 f$():=c$() 25 | 250 check3(f$, "OpenComal", 1) 26 | 260 // 27 | 270 PROC check(REF a(), value, change#) CLOSED 28 | 280 FOR f#:=1 TO 100 DO 29 | 290 IF a(f#)<>value THEN error 30 | 300 IF change# THEN a(f#):-1 31 | 310 ENDFOR f# 32 | 320 PRINT "Passed" 33 | 330 ENDPROC check 34 | 340 // 35 | 350 PROC check2(g#(), value#, change#) CLOSED 36 | 360 FOR f#:=1 TO 100 DO 37 | 370 IF g#(f#)<>value# THEN error 38 | 380 IF change# THEN g#(f#):-1 39 | 390 ENDFOR f# 40 | 400 PRINT "Passed" 41 | 410 ENDPROC check2 42 | 420 // 43 | 430 PROC check3(h$(), value$, indices#) 44 | 440 FOR f#:=0 TO 99 DO 45 | 450 IF indices#=1 THEN 46 | 460 a$:=h$(f#+1) 47 | 470 ELSE 48 | 480 a$:=h$(f# DIV 10+1, f# MOD 10+1) 49 | 490 ENDIF 50 | 500 IF a$<>value$ THEN error 51 | 510 ENDFOR f# 52 | 520 PRINT "Passed" 53 | 530 ENDPROC check3 54 | 540 // 55 | 550 PROC error 56 | 560 STOP "*not ok*" 57 | 570 ENDPROC error 58 | 580 // 59 | 590 PRINT "All ok" 60 | -------------------------------------------------------------------------------- /samples/tests/asn()1.lst: -------------------------------------------------------------------------------- 1 | 10 // ASN() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Please stand by for arc sinus check" 5 | 50 FOR f:=-1 TO 1 STEP 0.010000 DO 6 | 60 CURSOR 4,1 7 | 70 PRINT USING "#.#####": f; 8 | 80 d:=ABS(f-SIN(ASN(f))) 9 | 90 IF d>0.0000001 THEN STOP 10 | 100 ENDFOR 11 | 110 PRINT 12 | 120 PRINT "No abnormal differences found" 13 | -------------------------------------------------------------------------------- /samples/tests/assign1.lst: -------------------------------------------------------------------------------- 1 | 10 // Assignment sample program 2 | 20 // 3 | 30 a:=1 4 | 40 b$:="a" 5 | 50 c$:="abcdefghijklmnopqrstuvwxyz" 6 | 60 // 7 | 70 a:+1 8 | 80 a:-1 9 | 90 b$:+"b" 10 | 100 c$(1:4):="ABC" 11 | 110 // 12 | 120 PRINT a 13 | 130 PRINT b$ 14 | 140 PRINT c$ 15 | 150 // 16 | 160 IF a<>1 THEN STOP 17 | 170 IF b$<>"ab" THEN STOP 18 | 180 IF c$<>"ABC efghijklmnopqrstuvwxyz" THEN STOP 19 | 190 PRINT "All ok" 20 | -------------------------------------------------------------------------------- /samples/tests/atn()1.lst: -------------------------------------------------------------------------------- 1 | 10 // ATN() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Please stand by for arc tangent check" 5 | 50 FOR f:=0 TO 2*PI STEP 0.050000 DO 6 | 60 CURSOR 4,1 7 | 70 PRINT USING "#.####": f; 8 | 80 d:=(ABS(f-ATN(TAN(f)))) MOD PI 9 | 90 IF d>0.0000001 THEN STOP 10 | 100 ENDFOR 11 | 110 PRINT 12 | 120 PRINT "No abnormal differences found" 13 | -------------------------------------------------------------------------------- /samples/tests/bigarray.lst: -------------------------------------------------------------------------------- 1 | 10 // Checking whether an array bigger than 64K can be uses 2 | 20 // 3 | 30 nr#:=20000 4 | 40 DIM a(nr#) 5 | 50 // 6 | 60 FOR f#:=1 TO nr# DO 7 | 70 a(f#):=f# 8 | 80 IF f# MOD 100=0 THEN PRINT "Filling: ";f# 9 | 90 ENDFOR 10 | 100 // 11 | 110 FOR f#:=1 TO nr# DO 12 | 120 IF a(f#)<>f# THEN STOP 13 | 130 IF f# MOD 100=0 THEN PRINT "Checking: ";f# 14 | 140 ENDFOR 15 | 150 // 16 | 160 PRINT "All ok" 17 | -------------------------------------------------------------------------------- /samples/tests/bigstr.lst: -------------------------------------------------------------------------------- 1 | 10 // Checking whether a string bigger than 64K can be used 2 | 20 // 3 | 30 a$:="x" 4 | 40 l:=LEN(a$) 5 | 50 WHILE l<70000 DO 6 | 60 a$:=a$+a$ 7 | 70 l:=l*2 8 | 80 PRINT l 9 | 90 ENDWHILE 10 | 100 // 11 | 110 IF LEN(a$)<>l THEN STOP 12 | 120 // 13 | 130 FOR f:=1 TO l DO 14 | 140 IF f MOD 20000=0 THEN PRINT "Setting ";f 15 | 150 a$(f:f):=CHR$(f MOD 26+ORD("A")) 16 | 160 ENDFOR 17 | 170 // 18 | 180 FOR f:=1 TO l DO 19 | 190 IF f MOD 20000=0 THEN PRINT "Checking ";f 20 | 200 IF a$(f:f)<>CHR$(f MOD 26+ORD("A")) THEN STOP 21 | 210 ENDFOR 22 | 220 // 23 | 230 PRINT "All ok" 24 | -------------------------------------------------------------------------------- /samples/tests/case1.lst: -------------------------------------------------------------------------------- 1 | 10 // CASE sample program 2 | 20 // 3 | 30 FOR f:=1 TO 10 DO 4 | 40 PRINT "Kees is ";f;" "; 5 | 50 CASE f OF 6 | 60 // test kees 7 | 70 WHEN 1 8 | 80 PRINT "een" 9 | 90 WHEN <=2 10 | 100 PRINT "kleiner gelijk 2" 11 | 110 WHEN 6, 7 12 | 120 PRINT "zes of zeven" 13 | 130 WHEN >9 14 | 140 PRINT "groter negen" 15 | 150 OTHERWISE 16 | 160 PRINT "none of the above" 17 | 170 ENDCASE 18 | 180 // 19 | 190 ENDFOR 20 | -------------------------------------------------------------------------------- /samples/tests/check.prl: -------------------------------------------------------------------------------- 1 | 10 // check 2 | 20 // External procedure used in checking programs 3 | 30 // 4 | 40 PROC check(truth#) CLOSED 5 | 50 IF NOT(truth#) THEN 6 | 60 PRINT "Check failed" 7 | 70 STOP 8 | 80 ENDIF 9 | 90 ENDPROC 10 | -------------------------------------------------------------------------------- /samples/tests/chr$()1.lst: -------------------------------------------------------------------------------- 1 | 10 // CHR$() sample program 2 | 20 // 3 | 30 FOR f#:=ORD("A") TO ORD("Z") DO 4 | 40 PRINT CHR$(f#)," ", 5 | 50 ENDFOR 6 | 60 PRINT 7 | 70 PRINT "If the above reads the upper case alphabet, all is ok" 8 | -------------------------------------------------------------------------------- /samples/tests/close1.lst: -------------------------------------------------------------------------------- 1 | 10 // CLOSE sample program 2 | 20 // 3 | 25 ddelete 4 | 30 oopen 5 | 40 CLOSE 6 | 50 // 7 | 55 ddelete 8 | 60 oopen 9 | 70 CLOSE FILE 1 10 | 80 CLOSE FILE 2 11 | 90 // 12 | 95 ddelete 13 | 100 oopen 14 | 110 CLOSE FILE 1, 2 15 | 120 // 16 | 125 ddelete 17 | 130 oopen 18 | 140 CLOSE 19 | 150 // 20 | 160 PRINT "All ok" 21 | 170 // 22 | 180 PROC oopen 23 | 190 OPEN FILE 1, "ofile4", WRITE 24 | 200 OPEN FILE 2, "ofile5", WRITE 25 | 210 ENDPROC 26 | 220 // 27 | 230 PROC ddelete 28 | 240 TRAP 29 | 250 DELETE "ofile4" 30 | 260 ENDTRAP 31 | 270 TRAP 32 | 280 DELETE "ofile5" 33 | 290 ENDTRAP 34 | 300 ENDPROC 35 | -------------------------------------------------------------------------------- /samples/tests/closed1.lst: -------------------------------------------------------------------------------- 1 | 10 // CLOSED sample program 2 | 20 // 3 | 30 a:=1 4 | 40 aap 5 | 50 PRINT a 6 | 60 IF a<>1 THEN STOP 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 PROC aap CLOSED 11 | 110 a:=9 12 | 120 ENDPROC 13 | -------------------------------------------------------------------------------- /samples/tests/closed2.lst: -------------------------------------------------------------------------------- 1 | 10 // CLOSED sample program 2 | 20 // 3 | 30 a:=1 4 | 40 aap 5 | 50 PRINT a 6 | 60 IF a<>1 THEN STOP 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 PROC aap CLOSED 11 | 110 a:=9 12 | 120 olifant 13 | 130 ENDPROC 14 | 140 // 15 | 150 PROC olifant // Not CLOSED == OPEN! 16 | 160 PRINT a 17 | 170 IF a<>1 THEN STOP 18 | 180 ENDPROC 19 | -------------------------------------------------------------------------------- /samples/tests/common_external.lst: -------------------------------------------------------------------------------- 1 | 10 FUNC test'external CLOSED 2 | 20 // this test'external is only valid if 3 | 30 // called as an external func 4 | 40 RETURN TRUE 5 | 50 ENDFUNC test'external 6 | -------------------------------------------------------------------------------- /samples/tests/common_string.lst: -------------------------------------------------------------------------------- 1 | 10 DIM s$ OF 10, t$ OF 4 2 | 20 PRINT "=====testing substring assignment:" 3 | 30 s$(1:7):="abcde" 4 | 40 IF LEN(s$)=7 THEN 5 | 50 PRINT "correct length" 6 | 60 IF s$(7:7)=" " THEN 7 | 70 PRINT "correct padding with spaces" 8 | 80 ELSE 9 | 90 PRINT "failed padding with spaces" 10 | 100 ENDIF 11 | 110 ELSE 12 | 120 PRINT "failed - wrong length" 13 | 130 ENDIF 14 | 140 PRINT "=====testing auto truncating assignment" 15 | 150 t$:="abcde" 16 | 160 IF t$="abcd" THEN 17 | 170 PRINT "passed" 18 | 180 ELSE 19 | 190 PRINT "failed" 20 | 200 ENDIF 21 | 210 IF t$(2:3)<>"bc" THEN PRINT "failed" 22 | 220 PRINT "=====testing substrings" 23 | 230 t$:="abcd" 24 | 240 s$:=t$(2:) 25 | 250 IF s$="bcd" THEN 26 | 260 PRINT "passed (2:)" 27 | 270 ELSE 28 | 280 PRINT "failed (2:)" 29 | 290 ENDIF 30 | 300 s$:=t$(:3) 31 | 310 IF s$="abc" THEN 32 | 320 PRINT "passed (:3)" 33 | 330 ELSE 34 | 340 PRINT "failed (:3)" 35 | 350 ENDIF 36 | 360 s$:=t$(2:2) 37 | 370 IF s$="b" THEN 38 | 380 PRINT "passed (2:2)" 39 | 390 ELSE 40 | 400 PRINT "failed (2:2)" 41 | 410 ENDIF 42 | 420 PRINT "=====testing substring inserting" 43 | 430 t$(2:2):="x" 44 | 440 IF t$="axcd" THEN 45 | 450 PRINT "passed" 46 | 460 ELSE 47 | 470 PRINT "failed" 48 | 480 ENDIF 49 | 490 PRINT "=====testing string concatenating" 50 | 500 t$:="abcd" 51 | 510 s$:=t$+t$ 52 | 520 IF s$="abcdabcd" THEN 53 | 530 PRINT "passed" 54 | 540 ELSE 55 | 550 PRINT "failed" 56 | 560 ENDIF 57 | 570 s$:="z" 58 | 580 s$:+t$ 59 | 590 IF s$="zabcd" THEN 60 | 600 PRINT "passed" 61 | 610 ELSE 62 | 620 PRINT "failed" 63 | 630 ENDIF 64 | -------------------------------------------------------------------------------- /samples/tests/common_using.lst: -------------------------------------------------------------------------------- 1 | 10 DIM filename1$ OF 20, filename2$ OF 20 2 | 20 DIM reply$ OF 1 3 | 30 DIM text1$ OF 40, text2$ OF 40 4 | 40 filename1$:="uqtestzp.dat"; filename2$:="uqtestzu.dat" 5 | 60 PRINT "PRINT USING TEST" 6 | 70 PRINT "This program uses two disk files" 7 | 80 PRINT "that it creates, uses, then deletes." 8 | 90 PRINT filename1$;"and";filename2$ 9 | 100 PRINT "place blank formatted disk into" 10 | 110 INPUT "current drive. Hit return when ready:": reply$ 11 | 120 // 12 | 130 DELETE filename1$ 13 | 140 DELETE filename2$ 14 | 150 // 15 | 160 OPEN FILE 1,filename1$,WRITE // correct answer goes here 16 | 170 OPEN FILE 2,filename2$,WRITE // print usings go here 17 | 180 // 18 | 190 PRINT FILE 1: "test 120.0 test" 19 | 200 PRINT FILE 2: USING "test ###.# test": 120 20 | 210 // 21 | 220 PRINT FILE 1: "test 5.47 test" 22 | 230 PRINT FILE 2: USING "test -##.## test": 5.467 23 | 240 // 24 | 250 PRINT FILE 1: "test -5.47 test" 25 | 260 PRINT FILE 2: USING "test -##.## test": -5.467 26 | 270 // 27 | 280 PRINT FILE 1: "test ******* test" 28 | 290 PRINT FILE 2: USING "test ###.### test": 12345 29 | 300 // 30 | 310 PRINT FILE 1: "test 3 $ 55.00 test" 31 | 320 PRINT FILE 2: USING "test ### $###.## test": 3,55 32 | 330 // 33 | 340 CLOSE 34 | 350 // 35 | 360 PRINT "comparing the files now" 36 | 370 PRINT 37 | 380 OPEN FILE 1,filename1$,READ 38 | 390 OPEN FILE 2,filename2$,READ 39 | 400 passed:=TRUE //init 40 | 410 WHILE NOT (EOF(1) OR EOF(2)) DO 41 | 420 INPUT FILE 1: text1$ 42 | 430 INPUT FILE 2: text2$ 43 | 440 PRINT text1$ 44 | 450 PRINT text2$ 45 | 460 PRINT "==========" 46 | 470 IF text1$<>text2$ THEN passed:=FALSE 47 | 480 ENDWHILE 48 | 490 CLOSE 49 | 500 DELETE filename1$ 50 | 510 DELETE filename2$ 51 | 520 IF passed THEN 52 | 530 PRINT "====> All passed" 53 | 540 ELSE 54 | 550 PRINT "====> Failed" 55 | 560 ENDIF 56 | -------------------------------------------------------------------------------- /samples/tests/cos()1.lst: -------------------------------------------------------------------------------- 1 | 10 // COS() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Cosinus" 5 | 50 FOR f:=0 TO 2*PI STEP PI/32 DO 6 | 60 plot(f, COS(f)) 7 | 70 ENDFOR 8 | 80 CURSOR 23,1 9 | 90 PRINT "If the above looks like a cosine curve, it might be ok" 10 | 100 // 11 | 110 PROC plot(x, y) 12 | 120 x#:=1+INT(x*10) 13 | 130 y#:=11+10*y 14 | 140 CURSOR y#,x# 15 | 150 PRINT "*"; 16 | 160 ENDPROC 17 | -------------------------------------------------------------------------------- /samples/tests/cursor1.lst: -------------------------------------------------------------------------------- 1 | 10 // CURSOR sample program 2 | 20 // 3 | 30 PAGE 4 | 40 // 5 | 50 x#:=20 6 | 60 FOR y#:=2 TO 21 DO 7 | 70 CURSOR y#,x# 8 | 80 PRINT "XX"; 9 | 90 CURSOR 23-y#,x# 10 | 100 PRINT "XX"; 11 | 110 x#:+2 12 | 120 ENDFOR 13 | 130 // 14 | 140 CURSOR 23,1 15 | 150 PRINT "If the above looks like a big X, all is ok" 16 | -------------------------------------------------------------------------------- /samples/tests/deg()1.lst: -------------------------------------------------------------------------------- 1 | 10 // DEG() sample program 2 | 20 // 3 | 30 FOR f:=0 TO 2 STEP 1/4 DO 4 | 40 PRINT USING "#.##": f; 5 | 50 PRINT " PI = "; 6 | 60 d:=DEG(f*PI) 7 | 70 PRINT USING "###": d; 8 | 80 PRINT " degrees" 9 | 90 READ e 10 | 100 IF d<>e THEN STOP 11 | 110 ENDFOR 12 | 120 // 13 | 130 PRINT "All ok" 14 | 140 // 15 | 150 DATA 0, 45, 90, 135, 180, 225, 270, 315, 360 16 | -------------------------------------------------------------------------------- /samples/tests/delete1.lst: -------------------------------------------------------------------------------- 1 | 10 // DELETE sample program 2 | 20 // 3 | 30 SELECT OUTPUT "sel.out" 4 | 40 PRINT "Hello" // is moved into file 5 | 50 SELECT OUTPUT "" 6 | 60 // 7 | 70 DELETE "sel.out" 8 | 80 // 9 | 90 CASE SYS$(host) OF 10 | 100 WHEN "MsDos" 11 | 110 PASS "dir sel.out >temp" 12 | 120 WHEN "UNIX" 13 | 130 PASS "ls -l sel.out >temp" 14 | 140 OTHERWISE 15 | 150 PRINT "Unknown host" 16 | 160 STOP 17 | 170 ENDCASE 18 | 180 // 19 | 190 PASS "echo '*** finito ***' >>temp" 20 | 200 // 21 | 210 SELECT INPUT "temp" 22 | 220 REPEAT 23 | 230 INPUT a$ 24 | 240 IF "sel.out" IN a$ THEN STOP 25 | 250 UNTIL "*** finito ***" IN a$ 26 | 260 SELECT INPUT "" 27 | 270 // 28 | 280 DELETE "temp" 29 | 290 PRINT "All ok" 30 | -------------------------------------------------------------------------------- /samples/tests/deliet.prc: -------------------------------------------------------------------------------- 1 | SqAsHLinuxT(OpenComal/Sqash (c) 1992-2002 Muppet Lab' deliet external PROCedure'Z$'deliet  filename$y.'8'   filename$ +B'(L'(OpenComal/Sqash (c) 1992-2002 Muppet Lab -------------------------------------------------------------------------------- /samples/tests/deliet.prl: -------------------------------------------------------------------------------- 1 | 10000 // deliet external PROCedure 2 | 10010 // 3 | 10020 PROC deliet(filename$) CLOSED 4 | 10030 TRAP 5 | 10040 DELETE filename$ 6 | 10050 ENDTRAP 7 | 10060 ENDPROC 8 | -------------------------------------------------------------------------------- /samples/tests/dim1.lst: -------------------------------------------------------------------------------- 1 | 10 // DIM sample program 2 | 20 // 3 | 30 DIM a(4), b(-1:1, -1:1) 4 | 40 // 5 | 50 FOR f:=1 TO 4 DO a(f):=f 6 | 60 // 7 | 70 FOR f:=-1 TO 1 DO 8 | 80 FOR g:=-1 TO 1 DO 9 | 90 b(f, g):=f*g 10 | 100 ENDFOR 11 | 110 ENDFOR 12 | 120 // 13 | 130 trep(a(0)) 14 | 140 trep(a(5)) 15 | 150 trep(b(-2, 0)) 16 | 160 trep(b(0, -2)) 17 | 170 trep(b(-2, -2)) 18 | 180 trep(b(2, 0)) 19 | 190 trep(b(0, 2)) 20 | 200 trep(b(2, 2)) 21 | 210 // 22 | 220 FOR f:=4 DOWNTO 1 DO 23 | 230 IF a(f)<>f THEN STOP 24 | 240 ENDFOR 25 | 250 // 26 | 260 FOR f:=1 DOWNTO -1 DO 27 | 270 FOR g:=-1 TO 1 DO 28 | 280 IF b(f, g)<>f*g THEN STOP 29 | 290 ENDFOR 30 | 300 ENDFOR 31 | 310 // 32 | 320 PRINT "All ok" 33 | 330 // 34 | 340 PROC trep(NAME x) 35 | 350 TRAP 36 | 360 dummy:=x 37 | 370 STOP 38 | 380 ENDTRAP 39 | 390 ENDPROC 40 | -------------------------------------------------------------------------------- /samples/tests/dim2.lst: -------------------------------------------------------------------------------- 1 | 10 // DIM sample program 2 | 20 // 3 | 30 DIM b$(3) 4 | 40 // 5 | 50 FOR f:=1 TO 3 DO 6 | 60 b$(f):="Number = "+STR$(f) 7 | 70 ENDFOR 8 | 80 // 9 | 90 FOR f:=1 TO 3 DO 10 | 100 READ a$ 11 | 110 IF a$<>b$(f) THEN STOP 12 | 120 ENDFOR 13 | 130 // 14 | 140 PRINT "All ok" 15 | 150 // 16 | 160 DATA "Number = 1", "Number = 2", "Number = 3" 17 | -------------------------------------------------------------------------------- /samples/tests/dim3.lst: -------------------------------------------------------------------------------- 1 | 10 // DIM sample program 2 | 20 // 3 | 30 DIM a$ OF 4, b$(-10:10) OF 1 4 | 40 // 5 | 50 a$:="1234567890" 6 | 60 PRINT a$ 7 | 70 IF a$<>"1234" THEN STOP 8 | 80 // 9 | 90 FOR f:=-10 TO 10 DO 10 | 100 b$(f):=STR$(f) 11 | 110 PRINT b$(f) 12 | 120 ENDFOR 13 | 130 // 14 | 140 FOR f:=10 DOWNTO -10 DO 15 | 150 IF b$(f)<>STR$(f)(1:1) THEN STOP 16 | 160 ENDFOR 17 | 170 // 18 | 180 PRINT "All ok" 19 | -------------------------------------------------------------------------------- /samples/tests/dirs.lst: -------------------------------------------------------------------------------- 1 | 10 org$:=DIR$ 2 | 20 IF SYS$(host)="UNIX" THEN CHDIR "/tmp" 3 | 30 PRINT "Directory of ";DIR$ 4 | 40 DIR 5 | 50 MKDIR "a" 6 | 60 CHDIR "a" 7 | 70 PRINT "Directory of ";DIR$ 8 | 80 DIR 9 | 90 CHDIR ".." 10 | 100 RMDIR "a" 11 | 110 CHDIR org$ 12 | 120 PRINT "All ok" 13 | -------------------------------------------------------------------------------- /samples/tests/end1.lst: -------------------------------------------------------------------------------- 1 | 10 // END sample program 2 | 20 // 3 | 30 SELECT OUTPUT "temp" 4 | 40 PRINT "con" 5 | 50 PRINT "; \"If error 40 has occurred, all is ok" 6 | 60 SELECT OUTPUT "" 7 | 70 SYS sysin, "temp" 8 | 80 PRINT "CON won't help now" 9 | 90 END 10 | 100 PRINT "See, no continuation possible" 11 | 110 STOP 12 | -------------------------------------------------------------------------------- /samples/tests/eod1.lst: -------------------------------------------------------------------------------- 1 | 10 // EOD sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a 5 | 50 PRINT a 6 | 60 ENDWHILE 7 | 70 // 8 | 80 IF a<>25 THEN STOP 9 | 90 PRINT "All ok" 10 | 100 // 11 | 110 DATA 1, 4, 9, 16, 25 12 | -------------------------------------------------------------------------------- /samples/tests/eof()1.lst: -------------------------------------------------------------------------------- 1 | 10 // EOF() sample program 2 | 20 // 3 | 30 TRAP 4 | 40 DELETE "ofile3" 5 | 50 ENDTRAP 6 | 60 // 7 | 70 OPEN FILE 1, "ofile3", WRITE 8 | 80 FOR f#:=-1 TO RND(100) DO PRINT FILE 1: f# 9 | 90 CLOSE FILE 1 10 | 100 // 11 | 110 OPEN FILE 1, "ofile3", READ 12 | 120 WHILE NOT(EOF(1)) DO 13 | 130 INPUT FILE 1: f# 14 | 140 PRINT USING "#####": f#; 15 | 150 ENDWHILE 16 | 160 CLOSE FILE 1 17 | 170 // 18 | 180 PRINT 19 | -------------------------------------------------------------------------------- /samples/tests/exp()1.lst: -------------------------------------------------------------------------------- 1 | 10 // EXP() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Exponential (e^x)" 5 | 50 FOR f:=-1 TO 3 STEP 0.050000 DO 6 | 60 plot(f, EXP(f)) 7 | 70 ENDFOR 8 | 80 // 9 | 90 CURSOR 23,1 10 | 100 PRINT "If the above looks like an exponential curve, all might be ok" 11 | 110 // 12 | 120 PROC plot(x, y) 13 | 130 x#:=1+(x+1)*20 14 | 140 y#:=22-y 15 | 150 CURSOR y#,x# 16 | 160 PRINT "*"; 17 | 170 ENDPROC 18 | -------------------------------------------------------------------------------- /samples/tests/externa1.lst: -------------------------------------------------------------------------------- 1 | 10 // EXTERNAL sample program 2 | 20 // 3 | 30 aap:=0 4 | 40 FOR f:=1 TO 10 DO aap 5 | 50 IF aap<>10 THEN STOP 6 | 60 // 7 | 70 PRINT "All ok" 8 | 80 // 9 | 90 PROC aap EXTERNAL "aap1.prc" 10 | -------------------------------------------------------------------------------- /samples/tests/externa2.lst: -------------------------------------------------------------------------------- 1 | 10 // EXTERNAL sample program 2 | 20 // 3 | 30 aap:=0 4 | 40 FOR f:=1 TO 10 DO aap 5 | 50 IF aap<>10 THEN STOP 6 | 60 // 7 | 70 PRINT "All ok" 8 | 80 // 9 | 90 PROC aap DYNAMIC EXTERNAL "aap1.prc" 10 | -------------------------------------------------------------------------------- /samples/tests/externa3.lst: -------------------------------------------------------------------------------- 1 | 10 // EXTERNAL sample program 2 | 20 // 3 | 30 a$:="aap1.prc" 4 | 40 aap:=0 5 | 50 FOR f:=1 TO 10 DO aap 6 | 60 IF aap<>10 THEN STOP 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 PROC aap EXTERNAL a$ // Implicitly dynamic 11 | -------------------------------------------------------------------------------- /samples/tests/externa4.lst: -------------------------------------------------------------------------------- 1 | 10 // EXTERNAL sample program 2 | 20 // 3 | 30 a$:="aap1.prc" 4 | 40 aap:=0 5 | 50 FOR f:=1 TO 10 DO aap 6 | 60 IF aap<>10 THEN STOP 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 PROC aap STATIC EXTERNAL a$ 11 | -------------------------------------------------------------------------------- /samples/tests/externa5.lst: -------------------------------------------------------------------------------- 1 | 10 // EXTERNAL sample program 2 | 20 // 3 | 30 olifant:=0; tijger:=0 4 | 40 // 5 | 50 FOR f:=1 TO 10 DO olifant 6 | 60 // 7 | 70 IF olifant<>tijger OR olifant<>10 THEN STOP 8 | 80 // 9 | 90 PRINT "All ok" 10 | 100 // 11 | 110 PROC olifant EXTERNAL "aap3.prc" 12 | 120 // 13 | 130 PROC tijger 14 | 140 PRINT "In tijger" 15 | 150 tijger:+1 16 | 160 ENDPROC 17 | -------------------------------------------------------------------------------- /samples/tests/false1.lst: -------------------------------------------------------------------------------- 1 | 10 // FALSE sample program 2 | 20 // 3 | 30 PRINT FALSE 4 | 40 PRINT 1=0 5 | 50 IF (1=0)<>FALSE THEN STOP 6 | 60 PRINT "All ok" 7 | -------------------------------------------------------------------------------- /samples/tests/for1.lst: -------------------------------------------------------------------------------- 1 | 10 // FOR sample program 2 | 20 // 3 | 30 toe(1, 4, 1, "Van 1 tot 4") 4 | 40 toe(4, 1, 1, "Niets") 5 | 50 downtoe(4, 1, 1, "Van 4 tot 1") 6 | 60 downtoe(1, 4, 1, "Niets") 7 | 70 toe(1, 4, 2, "Van 1 tot 4 step 2") 8 | 80 toe(4, 1, 2, "Niets") 9 | 90 downtoe(4, 1, 2, "Van 4 tot 1 step 2") 10 | 100 downtoe(1, 4, 2, "Niets") 11 | 110 toe(1, 4, -1, "Niets") 12 | 120 toe(4, 1, -1, "Van 4 tot 1 step -1") 13 | 130 downtoe(4, 1, -1, "Niets") 14 | 140 downtoe(1, 4, -1, "Van 1 tot 4") 15 | 150 // 16 | 160 PROC toe(van, tot, stap, title$) 17 | 170 PRINT title$;" "; 18 | 180 FOR f:=van TO tot STEP stap DO PRINT f;" "; 19 | 190 PRINT 20 | 200 ENDPROC 21 | 210 // 22 | 220 PROC downtoe(van, tot, stap, title$) 23 | 230 PRINT title$;" "; 24 | 240 FOR f:=van DOWNTO tot STEP stap DO 25 | 250 PRINT f;" "; 26 | 260 ENDFOR 27 | 270 PRINT 28 | 280 ENDPROC 29 | -------------------------------------------------------------------------------- /samples/tests/func1.lst: -------------------------------------------------------------------------------- 1 | 10 // FUNC sample program 2 | 20 // 3 | 30 IF aap(2)<>4 THEN STOP 4 | 40 IF aap#(3)<>9 THEN STOP 5 | 50 IF aap$(4)<>"16" THEN STOP 6 | 60 // 7 | 70 PRINT "All ok" 8 | 80 // 9 | 90 FUNC aap(num#) 10 | 100 PRINT "FUNC aap active" 11 | 110 RETURN num#*2 12 | 120 ENDFUNC 13 | 130 // 14 | 140 FUNC aap#(num#) 15 | 150 PRINT "FUNC aap# active" 16 | 160 RETURN num#*3 17 | 170 ENDFUNC 18 | 180 // 19 | 190 FUNC aap$(num#) 20 | 200 PRINT "FUNC aap$ active" 21 | 210 RETURN STR$(num#*4) 22 | 220 ENDFUNC 23 | -------------------------------------------------------------------------------- /samples/tests/func2.lst: -------------------------------------------------------------------------------- 1 | 10 // FUNC sample program 2 | 20 // 3 | 30 f#:=0; g:=0 4 | 40 IF aap<>1 THEN STOP 5 | 50 IF aap#<>2 THEN STOP 6 | 60 IF f#<>0 OR g<>0 THEN STOP 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 FUNC aap CLOSED 11 | 110 f#:=1 12 | 120 RETURN f# 13 | 130 ENDFUNC 14 | 140 // 15 | 150 FUNC aap# CLOSED 16 | 160 g:=2 17 | 170 RETURN g 18 | 180 ENDFUNC 19 | -------------------------------------------------------------------------------- /samples/tests/gentest.lst: -------------------------------------------------------------------------------- 1 | 10 // Generate Sysinp file to run all test programs 2 | 20 // 3 | 30 DIM filename$ OF 12 4 | 40 // 5 | 50 TRAP 6 | 60 DELETE "runit.in" 7 | 70 ENDTRAP 8 | 80 // 9 | 90 REPEAT 10 | 100 INPUT "Should I generate an attended or an unattended test? (A/U) ": a$ 11 | 110 UNTIL a$="A" OR a$="U" 12 | 120 // 13 | 130 genrun(".sq") 14 | 140 SYS sysin, "runit.in" 15 | 150 // 16 | 160 PROC genrun(f$) 17 | 170 CASE SYS$(host) OF 18 | 180 WHEN "MsDos" 19 | 190 PASS "dir *"+f$+" >temp" 20 | 200 WHEN "UNIX" 21 | 210 PASS "ls *"+f$+" >temp" 22 | 220 PASS "echo Finito >>temp" 23 | 230 OTHERWISE 24 | 240 PRINT "Unknown host" 25 | 250 STOP 26 | 260 ENDCASE 27 | 270 // 28 | 280 SELECT INPUT "temp" 29 | 290 // 30 | 300 REPEAT 31 | 310 INPUT filename$ 32 | 320 UNTIL f$ IN filename$ 33 | 330 // 34 | 340 SELECT OUTPUT "runit.in" 35 | 350 IF a$="U" THEN PRINT "sys sysout,""runit.out" 36 | 360 // 37 | 370 WHILE f$ IN filename$ DO 38 | 380 filename$:=filename$(1:f$ IN filename$-1) 39 | 390 IF NOT(filename$ IN "gentest.sq2lst,lst2sq,slpl,common,common_external,common_file,common_string,common_using") THEN 40 | 400 IF a$="A" THEN 41 | 410 PRINT "10 // Force question to proceed with next program" 42 | 420 ENDIF 43 | 430 PRINT "print ""About to process test program "+filename$ 44 | 440 PRINT "load \"",filename$,f$ 45 | 450 PRINT "list" 46 | 460 PRINT "run" 47 | 470 ENDIF 48 | 480 INPUT filename$ 49 | 490 ENDWHILE 50 | 500 // 51 | 510 // 52 | 520 IF a$="U" THEN PRINT "sys sysout,""""" 53 | 530 SELECT INPUT "" 54 | 540 SELECT OUTPUT "" 55 | 550 // 56 | 560 ENDPROC 57 | -------------------------------------------------------------------------------- /samples/tests/hex.prl: -------------------------------------------------------------------------------- 1 | 10 // A function for converting a number to hex 2 | 20 FUNC hex$(n#) CLOSED 3 | 30 FUNC hexdigit$(n#) 4 | 40 RETURN "0123456789ABCDEF"(n#+1:n#+1) 5 | 50 ENDFUNC 6 | 60 // 7 | 70 IF n#<16 THEN RETURN hexdigit$(n#) 8 | 80 RETURN hex$(n# DIV 16)+hexdigit$(n# MOD 16) 9 | 90 ENDFUNC 10 | -------------------------------------------------------------------------------- /samples/tests/id1.lst: -------------------------------------------------------------------------------- 1 | 10 // Identifier sample program 2 | 20 // 3 | 30 aap:=aap 4 | 40 aap#:=2 5 | 50 aap$:="Hallo allemaal" 6 | 60 aap 7 | 70 // 8 | 80 FUNC aap 9 | 90 PRINT "Hello from func aap" 10 | 100 RETURN 3 11 | 110 ENDFUNC 12 | 120 // 13 | 130 PROC aap 14 | 140 PRINT "Hello from proc aap" 15 | 150 PRINT aap 16 | 160 PRINT aap# 17 | 170 PRINT aap$ 18 | 180 olifant 19 | 190 ENDPROC 20 | 200 // 21 | 210 PROC olifant CLOSED 22 | 220 PRINT aap 23 | 230 ENDPROC 24 | -------------------------------------------------------------------------------- /samples/tests/id2.lst: -------------------------------------------------------------------------------- 1 | 10 // Identifier sample program 2 | 20 // 3 | 30 aap:=1 4 | 40 aap_aap:=1 5 | 50 aap'aap:=1 6 | 60 // 7 | 70 // Now for some weird consequences 8 | 80 // 9 | 90 'aap':=2 10 | 100 _aap_:=3 11 | 110 _:=1 12 | 120 ':=1 13 | 130 ''_'':=9 14 | 140 '$:="hallo" 15 | 150 _$:="hello" 16 | -------------------------------------------------------------------------------- /samples/tests/if1.lst: -------------------------------------------------------------------------------- 1 | 10 // IF sample program 2 | 20 // 3 | 30 a:=4 4 | 40 b:=8 5 | 50 // 6 | 60 IF a=b THEN PRINT "4=8, something is wrong" 7 | 70 // 8 | 80 IF a<>b THEN 9 | 90 PRINT "4<>8" 10 | 100 ENDIF 11 | 110 // 12 | 120 IF a=b THEN 13 | 130 PRINT "4=8?" 14 | 140 ELSE 15 | 150 PRINT "4<>8" 16 | 160 ENDIF 17 | 170 // 18 | 180 IF a=b THEN 19 | 190 PRINT "4=8?" 20 | 200 ELIF a>b 21 | 210 PRINT "4>8?" 22 | 220 ELIF ab OR a<>6 THEN STOP 9 | 90 // 10 | 100 PRINT "All ok" 11 | 110 // 12 | 120 PROC aap CLOSED 13 | 130 IMPORT a 14 | 140 a:=6 15 | 150 b:=6 16 | 160 olifant 17 | 170 ENDPROC 18 | 180 // 19 | 190 PROC olifant CLOSED 20 | 200 IMPORT aap: b 21 | 210 b:=9 22 | 220 tijger 23 | 230 ENDPROC 24 | 240 // 25 | 250 PROC tijger CLOSED 26 | 260 IMPORT _program: b 27 | 270 b:=6 28 | 280 ENDPROC 29 | -------------------------------------------------------------------------------- /samples/tests/import2.lst: -------------------------------------------------------------------------------- 1 | 10 // IMPORT sample program 2 | 20 // 3 | 30 a$:="main program" 4 | 40 aap 5 | 50 PRINT "Ex main: a$=";a$ 6 | 60 // 7 | 70 PROC aap CLOSED 8 | 80 a$:="proc aap" 9 | 90 aap1 10 | 100 aap2 11 | 110 PRINT "Ex aap : a$=";a$ 12 | 120 // 13 | 130 PROC aap1 CLOSED 14 | 140 IMPORT a$ 15 | 150 PRINT "In aap1: a$=";a$ 16 | 160 a$:="Modified in aap1" 17 | 170 ENDPROC 18 | 180 // 19 | 190 PROC aap2 CLOSED 20 | 200 IMPORT _program: a$ 21 | 210 PRINT "In aap2: a$=";a$ 22 | 220 a$:="Modified in aap2" 23 | 230 ENDPROC 24 | 240 // 25 | 250 ENDPROC 26 | -------------------------------------------------------------------------------- /samples/tests/input#1.lst: -------------------------------------------------------------------------------- 1 | 10 // INPUT FILE sample program 2 | 20 // 3 | 30 deliet("ofile12") 4 | 40 // 5 | 50 DIM a$(10) 6 | 60 // 7 | 70 FOR f:=1 TO 10 DO a$(f):="Number "+STR$(f) 8 | 80 // 9 | 90 OPEN FILE 1, "ofile12", WRITE 10 | 100 PRINT FILE 1: a$() 11 | 110 CLOSE FILE 1 12 | 120 // 13 | 130 OPEN FILE 1, "ofile12", READ 14 | 140 FOR f:=1 TO 10 DO 15 | 150 INPUT FILE 1: b$ 16 | 160 IF b$<>"Number "+STR$(f) THEN STOP 17 | 170 ENDFOR f 18 | 180 CLOSE FILE 1 19 | 190 // 20 | 200 a$:="" // Assignment of array 21 | 210 // 22 | 220 OPEN FILE 1, "ofile12", READ 23 | 230 INPUT FILE 1: a$() // INPUT FILE of array() 24 | 240 CLOSE 25 | 250 // 26 | 260 FOR f:=1 TO 10 DO 27 | 270 IF a$(f)<>"Number 1" THEN STOP 28 | 280 ENDFOR f 29 | 290 // 30 | 300 PRINT "All ok" 31 | 310 // 32 | 320 PROC deliet EXTERNAL "deliet.prc" 33 | -------------------------------------------------------------------------------- /samples/tests/input1.lst: -------------------------------------------------------------------------------- 1 | 10 // INPUT sample program 2 | 20 // 3 | 30 deliet("ofile2") 4 | 40 // 5 | 50 SELECT OUTPUT "ofile2" 6 | 60 WHILE NOT(EOD) DO 7 | 70 READ a$ 8 | 80 PRINT a$ 9 | 90 ENDWHILE 10 | 100 SELECT OUTPUT "" 11 | 110 // 12 | 120 SELECT INPUT "ofile2" 13 | 130 INPUT a, b, c 14 | 140 PRINT a;" ";b;" ";c 15 | 150 INPUT a$ 16 | 160 PRINT ">";a$;"<" 17 | 170 INPUT a$, b, c$ 18 | 180 PRINT a$;" ";b;" ";c$ 19 | 190 SELECT INPUT "" 20 | 200 // 21 | 210 DATA "1, 2, 3 " 22 | 220 DATA " Dit is een test " 23 | 230 DATA "\"deze string bevat een , zie je wel\" , 99, aapje" 24 | 240 // 25 | 250 PROC deliet EXTERNAL "deliet.prc" 26 | -------------------------------------------------------------------------------- /samples/tests/int()1.lst: -------------------------------------------------------------------------------- 1 | 10 // INT() sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a, b# 5 | 50 PRINT INT(a) 6 | 60 IF INT(a)<>b# THEN STOP 7 | 70 ENDWHILE 8 | 80 // 9 | 90 PRINT "All ok" 10 | 100 // 11 | 110 DATA 1, 1, -1, -1, 2.500000, 2, -2.500000, -3, 0.001000, 0, -0.001000, -1 12 | -------------------------------------------------------------------------------- /samples/tests/len()1.lst: -------------------------------------------------------------------------------- 1 | 10 // LEN() sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a$, b 5 | 50 PRINT ">";a$;"< Length = ";LEN(a$) 6 | 60 IF LEN(a$)<>b THEN STOP 7 | 70 ENDWHILE 8 | 80 // 9 | 90 PRINT "All ok" 10 | 100 // 11 | 110 DATA "Jos", 3, "Visser", 6, "", 0 12 | -------------------------------------------------------------------------------- /samples/tests/local1.lst: -------------------------------------------------------------------------------- 1 | 10 // LOCAL sample program 2 | 20 // 3 | 30 a:=1 4 | 40 b$:="Jos Visser" 5 | 50 DIM reeks(3) 6 | 60 reeks:=9 7 | 70 aap 8 | 80 // 9 | 90 PRINT a 10 | 100 IF a<>1 THEN STOP 11 | 110 PRINT b$ 12 | 120 IF b$<>"Jos Visser" THEN STOP 13 | 130 FOR f:=1 TO 3 DO 14 | 140 PRINT reeks(f) 15 | 150 IF reeks(f)<>9 THEN STOP 16 | 160 ENDFOR 17 | 170 // 18 | 180 PRINT "All ok" 19 | 190 // 20 | 200 PROC aap 21 | 210 LOCAL a, b$, c$ OF 1, reeks(-10:-3) 22 | 220 a:=99 23 | 230 b$:="visser, jos" 24 | 240 reeks:=-100 25 | 250 ENDPROC 26 | -------------------------------------------------------------------------------- /samples/tests/log()1.lst: -------------------------------------------------------------------------------- 1 | 10 // LOG() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Natural logarithm" 5 | 50 FOR f:=0.050000 TO 4 STEP 0.050000 DO 6 | 60 plot(f, LOG(f)) 7 | 70 ENDFOR 8 | 80 // 9 | 90 CURSOR 23,1 10 | 100 PRINT "If the above looks like a natural logarithm curve, all might be ok" 11 | 110 // 12 | 120 PROC plot(x, y) 13 | 130 x#:=INT(x*20) 14 | 140 y#:=11-5*y 15 | 150 CURSOR y#,x# 16 | 160 PRINT "*"; 17 | 170 ENDPROC 18 | -------------------------------------------------------------------------------- /samples/tests/log10()1.lst: -------------------------------------------------------------------------------- 1 | 10 // LOG10() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "10-logarithm" 5 | 50 FOR f:=0.050000 TO 4 STEP 0.050000 DO 6 | 60 plot(f, LOG10(f)) 7 | 70 ENDFOR 8 | 80 // 9 | 90 CURSOR 23,1 10 | 100 PRINT "If the above looks like a 10-logarithm curve, it might be ok" 11 | 110 // 12 | 120 PROC plot(x, y) 13 | 130 x#:=INT(x*20) 14 | 140 y#:=11-6*y 15 | 150 CURSOR y#,x# 16 | 160 PRINT "*"; 17 | 170 ENDPROC 18 | -------------------------------------------------------------------------------- /samples/tests/logop1.lst: -------------------------------------------------------------------------------- 1 | 10 p("and", t AND t, res_normal) 2 | 20 p("or", t OR t, res_normal) 3 | 30 p("eor", t EOR t, res_normal) 4 | 40 p("and then", t AND THEN t, res_andthen) 5 | 50 p("or then", t OR THEN t, res_orthen) 6 | 60 // 7 | 70 PROC p(op$, NAME logexp, PROC restore_proc) 8 | 80 restore_proc 9 | 90 FOR i:=1 TO 4 DO 10 | 100 PRINT op$;" ";logexp 11 | 110 ENDFOR 12 | 120 ENDPROC 13 | 130 // 14 | 140 FUNC t CLOSED 15 | 150 READ k 16 | 160 PRINT k;" "; 17 | 170 RETURN k 18 | 180 ENDFUNC 19 | 190 // 20 | 200 normal: 21 | 210 DATA 0, 0, 0, 1, 1, 0, 1, 1 22 | 220 // 23 | 230 andthen: 24 | 240 DATA 0, 1, 0, 1, 1, 0 25 | 250 // 26 | 260 orthen: 27 | 270 DATA 0, 0, 0, 1, 1, 1 28 | 280 // 29 | 290 PROC res_normal 30 | 300 RESTORE normal 31 | 310 ENDPROC 32 | 320 // 33 | 330 PROC res_andthen 34 | 340 RESTORE andthen 35 | 350 ENDPROC 36 | 360 // 37 | 370 PROC res_orthen 38 | 380 RESTORE orthen 39 | 390 ENDPROC 40 | 400 // 41 | -------------------------------------------------------------------------------- /samples/tests/loop1.lst: -------------------------------------------------------------------------------- 1 | 10 // LOOP sample program 2 | 20 // 3 | 30 i:=1 4 | 40 LOOP 5 | 50 i:+1 6 | 60 EXIT WHEN i=10 7 | 70 ENDLOOP 8 | 80 // 9 | 90 IF i<>10 THEN STOP 10 | 100 // 11 | 110 LOOP 12 | 120 i:-1 13 | 130 IF i=0 THEN EXIT 14 | 140 ENDLOOP 15 | 150 // 16 | 160 IF i<>0 THEN STOP 17 | 170 // 18 | 180 PRINT "All ok" 19 | -------------------------------------------------------------------------------- /samples/tests/lst2sq.lst: -------------------------------------------------------------------------------- 1 | 10 // lst2sq 2 | 20 // Convert ASCII shipped programs to PDComal SAVE format 3 | 30 // 4 | 40 TRAP 5 | 50 DELETE "convert.in" 6 | 60 ENDTRAP 7 | 70 // 8 | 80 convert(".lst", ".sq") 9 | 90 convert(".prl", ".prc") 10 | 100 SYS sysin, "convert.in" 11 | 110 // 12 | 120 PROC convert(f$, t$) 13 | 130 CASE SYS$(host) OF 14 | 140 WHEN "MsDos" 15 | 150 PASS "dir *"+f$+" >temp" 16 | 160 WHEN "UNIX" 17 | 170 PASS "ls *"+f$+" >temp" 18 | 180 PASS "echo finito >>temp" 19 | 190 OTHERWISE 20 | 200 PRINT "Unknown host" 21 | 210 STOP 22 | 220 ENDCASE 23 | 230 SELECT INPUT "temp" 24 | 240 // 25 | 250 REPEAT 26 | 260 INPUT filename$ 27 | 270 UNTIL f$ IN filename$ AND NOT("*" IN filename$) 28 | 280 // 29 | 290 SELECT OUTPUT "convert.in" 30 | 300 WHILE f$ IN filename$ DO 31 | 310 filename$:=filename$(1:f$ IN filename$-1) 32 | 320 PRINT "print \"Processing "+filename$ 33 | 325 PRINT "new" 34 | 330 PRINT "enter \""+filename$+f$ 35 | 340 PRINT "save \""+filename$+t$ 36 | 370 INPUT filename$ 37 | 380 ENDWHILE 38 | 390 SELECT OUTPUT "" 39 | 400 ENDPROC 40 | -------------------------------------------------------------------------------- /samples/tests/name1.lst: -------------------------------------------------------------------------------- 1 | 10 // NAME sample program 2 | 20 // 3 | 30 a$:="Visser" 4 | 40 aap(naam$+" "+a$) 5 | 50 // 6 | 60 PROC aap(NAME fullname$) 7 | 70 naam$:="Jos" 8 | 80 PRINT fullname$ 9 | 90 naam$:="Patrick" 10 | 100 PRINT fullname$ 11 | 110 naam$:="Piet" 12 | 120 PRINT fullname$ 13 | 130 naam$:="Yvonne" 14 | 140 olifant("The name is "+fullname$) 15 | 150 ENDPROC 16 | 160 // 17 | 170 PROC olifant(NAME f$) CLOSED 18 | 180 naam$:="Tosca" 19 | 190 PRINT f$ // Remember, NAMEs are evaluated IN THEIR CALLING ENVIRONMENT! 20 | 200 ENDPROC 21 | -------------------------------------------------------------------------------- /samples/tests/not()1.lst: -------------------------------------------------------------------------------- 1 | 10 // NOT() sample program 2 | 20 // 3 | 30 a:=TRUE=NOT(FALSE) 4 | 40 b:=FALSE=NOT(TRUE) 5 | 50 IF a<>b OR a<>1 THEN STOP 6 | 60 PRINT "All ok" 7 | -------------------------------------------------------------------------------- /samples/tests/null1.lst: -------------------------------------------------------------------------------- 1 | 10 // NULL sample program 2 | 20 // 3 | 30 FOR f:=1 TO 100 DO NULL 4 | 40 PRINT "All ok" 5 | -------------------------------------------------------------------------------- /samples/tests/op_assig.lst: -------------------------------------------------------------------------------- 1 | 10 // op_assign 2 | 20 // Test assignment operators 3 | 30 // 4 | 40 PROC check EXTERNAL "check.prc" 5 | 50 // 6 | 60 a:=1 7 | 70 check(a=1) 8 | 80 a:+4 9 | 90 check(a=5) 10 | 100 a:-8 11 | 110 check(a=-3) 12 | 120 // 13 | 130 b#:=2 14 | 140 check(b#=2) 15 | 150 b#:+8 16 | 160 check(b#=10) 17 | 170 b#:-10 18 | 180 check(b#=0) 19 | 190 // 20 | 200 c$:="jos" 21 | 210 check(c$="jos") 22 | 220 c$:+" visser" 23 | 230 check(c$="jos visser") 24 | 240 // 25 | 250 DIM d$ OF 3 26 | 260 d$:="jos visser" 27 | 270 check(d$="jos") 28 | 280 d$:="j" 29 | 290 check(d$="j") 30 | 300 d$:+"os visser" 31 | 310 check(d$="jos") 32 | 320 // 33 | 330 PRINT "All ok" 34 | -------------------------------------------------------------------------------- /samples/tests/ord()1.lst: -------------------------------------------------------------------------------- 1 | 10 // ORD() sample program 2 | 20 // REM: ASCII DEPENDENCY! 3 | 30 // 4 | 40 WHILE NOT(EOD) DO 5 | 50 READ a$, o 6 | 60 PRINT ORD(a$) 7 | 70 IF ORD(a$)<>o THEN STOP 8 | 80 ENDWHILE 9 | 90 // 10 | 100 PRINT "All ok" 11 | 110 // 12 | 120 DATA "0", 48, "9", 57, "A", 65, "Z", 90, "a", 97, "z", 122 13 | -------------------------------------------------------------------------------- /samples/tests/page1.lst: -------------------------------------------------------------------------------- 1 | 10 // PAGE sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "This is printed on a new (clear) screen" 5 | -------------------------------------------------------------------------------- /samples/tests/pass1.lst: -------------------------------------------------------------------------------- 1 | 10 // PASS sample program 2 | 20 // 3 | 30 CASE SYS$(host) OF 4 | 40 WHEN "MsDos" 5 | 50 PASS "ver" 6 | 60 WHEN "UNIX" 7 | 70 PASS "uname -a" 8 | 80 OTHERWISE 9 | 90 PRINT "Unknown host" 10 | 100 STOP 11 | 110 ENDCASE 12 | 120 // 13 | 130 PRINT "All ok" 14 | -------------------------------------------------------------------------------- /samples/tests/pi1.lst: -------------------------------------------------------------------------------- 1 | 10 // PI sample program 2 | 20 // 3 | 30 PRINT "Pi = "; 4 | 40 PRINT USING "#.################": PI 5 | 50 IF INT(PI*100)<>314 THEN STOP 6 | 60 PRINT "All ok" 7 | -------------------------------------------------------------------------------- /samples/tests/print#1.lst: -------------------------------------------------------------------------------- 1 | 10 // PRINT FILE sample program 2 | 20 // 3 | 30 TRAP 4 | 40 DELETE "ofile10" 5 | 50 ENDTRAP 6 | 60 // 7 | 70 OPEN FILE 1, "ofile10", WRITE 8 | 80 DIM a$(10) 9 | 90 FOR f:=1 TO 10 DO a$(f):="Number "+STR$(f) 10 | 100 // 11 | 110 TRAP 12 | 120 PRINT FILE 1: a$ // PRINT FILE of array() not allowed 13 | 130 STOP 14 | 140 HANDLER 15 | 150 IF ERR<>16 THEN STOP 16 | 160 PRINT "Expected error occurred: ";ERRTEXT$ 17 | 170 ENDTRAP 18 | 180 // 19 | 190 FOR f:=1 TO 10 DO PRINT FILE 1: a$(f) 20 | 200 CLOSE 21 | 210 // 22 | 220 a$:="Leeg" 23 | 230 // 24 | 240 OPEN FILE 1, "ofile10", READ 25 | 250 FOR f:=1 TO 10 DO INPUT FILE 1: a$(f) 26 | 260 CLOSE 27 | 270 // 28 | 280 FOR f:=10 DOWNTO 1 DO 29 | 290 IF a$(f)<>"Number "+STR$(f) THEN STOP 30 | 300 ENDFOR 31 | 310 // 32 | 320 PRINT "All ok" 33 | -------------------------------------------------------------------------------- /samples/tests/proc1.lst: -------------------------------------------------------------------------------- 1 | 10 // PROC sample program 2 | 20 // 3 | 30 a:=0 4 | 40 hallo 5 | 50 IF a<>2 THEN STOP 6 | 60 PRINT "All ok" 7 | 70 // 8 | 80 PROC hallo 9 | 90 a:+1 10 | 100 PRINT "Hello "; 11 | 110 bob 12 | 120 ENDPROC 13 | 130 // 14 | 140 PROC bob 15 | 150 a:+1 16 | 160 PRINT "Bob" 17 | 170 ENDPROC 18 | -------------------------------------------------------------------------------- /samples/tests/proc2.lst: -------------------------------------------------------------------------------- 1 | 10 // PROC sample program 2 | 20 // 3 | 30 aap(1, 2.500000, "Hallo") 4 | 40 PRINT "All ok" 5 | 50 // 6 | 60 PROC aap(a#, b, c$) 7 | 70 PRINT a# 8 | 80 IF a#<>1 THEN STOP 9 | 90 PRINT b 10 | 100 IF b<>2.500000 THEN STOP 11 | 110 PRINT c$ 12 | 120 IF c$<>"Hallo" THEN STOP 13 | 130 ENDPROC 14 | -------------------------------------------------------------------------------- /samples/tests/proc3.lst: -------------------------------------------------------------------------------- 1 | 10 // PROC sample program 2 | 20 // 3 | 21 a#:=9; b:=9; c$:="9" 4 | 30 aap(1, 2.500000, "Hallo") 5 | 40 PRINT "All ok" 6 | 50 // 7 | 60 PROC aap(a#, b, c$) 8 | 70 PRINT a# 9 | 80 IF a#<>1 THEN STOP 10 | 90 PRINT b 11 | 100 IF b<>2.500000 THEN STOP 12 | 110 PRINT c$ 13 | 120 IF c$<>"Hallo" THEN STOP 14 | 130 ENDPROC 15 | -------------------------------------------------------------------------------- /samples/tests/proc4.lst: -------------------------------------------------------------------------------- 1 | 10 // PROC sample program 2 | 20 // 3 | 30 DIM a$(5), b$(5) 4 | 40 a$:="String a" 5 | 50 b$:="String b" 6 | 60 aap(a$, b$) 7 | 70 PRINT "----" 8 | 80 FOR f:=1 TO 5 DO 9 | 90 IF a$(f)<>"String a" THEN STOP 10 | 100 ENDFOR 11 | 110 FOR f:=1 TO 5 DO 12 | 120 IF b$(f)<>"A$" THEN STOP 13 | 130 ENDFOR 14 | 140 // 15 | 150 PRINT "All ok" 16 | 160 // 17 | 170 PROC aap(b$(), REF a$()) 18 | 180 PRINT b$(1) 19 | 190 PRINT a$(1) 20 | 200 b$:="B$" 21 | 210 a$:="A$" 22 | 220 ENDPROC 23 | -------------------------------------------------------------------------------- /samples/tests/proc5.lst: -------------------------------------------------------------------------------- 1 | 10 // PROC sample program 2 | 20 // 3 | 30 aap'olifant:=0 4 | 40 tijger'olifant:=0 5 | 50 aap 6 | 60 IF aap'olifant<>tijger'olifant OR aap'olifant<>1 THEN STOP 7 | 70 PRINT "All ok" 8 | 80 // 9 | 90 PROC aap 10 | 100 olifant 11 | 110 tijger 12 | 120 // 13 | 130 PROC olifant 14 | 140 aap'olifant:+1 15 | 150 PRINT "In aap.olifant" 16 | 160 ENDPROC 17 | 170 // 18 | 180 ENDPROC 19 | 190 // 20 | 200 PROC tijger 21 | 210 PRINT "In tijger" 22 | 220 olifant 23 | 230 // 24 | 240 PROC olifant 25 | 250 tijger'olifant:+1 26 | 260 PRINT "In tijger.olifant" 27 | 270 ENDPROC 28 | 280 // 29 | 290 ENDPROC 30 | 300 // 31 | 310 PROC olifant 32 | 320 PRINT "In olifant" 33 | 330 STOP 34 | 340 ENDPROC 35 | -------------------------------------------------------------------------------- /samples/tests/rad()1.lst: -------------------------------------------------------------------------------- 1 | 10 // RAD() sample program 2 | 20 // 3 | 30 FOR f:=0 TO 360 STEP 30 DO 4 | 40 PRINT USING "###": f; 5 | 50 PRINT " degrees = "; 6 | 60 r:=RAD(f)/PI 7 | 70 READ q 8 | 80 IF (r-q>0.000000) THEN STOP 9 | 90 PRINT USING "#.################": r; 10 | 100 PRINT " PI radians" 11 | 110 ENDFOR 12 | 120 // 13 | 130 PRINT "All ok" 14 | 140 // 15 | 150 DATA 0/12, 2/12, 4/12, 6/12, 8/12, 10/12, 12/12, 14/12, 16/12, 18/12, 20/12 16 | 160 DATA 22/12, 24/12 17 | -------------------------------------------------------------------------------- /samples/tests/random1.lst: -------------------------------------------------------------------------------- 1 | 10 // RANDOM sample program 2 | 13 // This test has a dependency on the machine word size 3 | 16 // For 32-bit machines, 18 & 9 below must be replaced with 10 & 5 4 | 20 // 5 | 30 TRAP 6 | 40 DELETE "ofile7" 7 | 50 ENDTRAP 8 | 60 // 9 | 70 OPEN FILE 1, "ofile7", RANDOM 18 10 | 80 FOR f#:=1 TO 50 DO WRITE FILE 1,f#: 2*f#,2*f#+1 11 | 90 CLOSE FILE 1 12 | 100 // 13 | 110 OPEN FILE 1, "ofile7", RANDOM 9 14 | 120 FOR f#:=100 DOWNTO 1 DO 15 | 130 READ FILE 1,f#: g# 16 | 140 PRINT USING "####": g#; 17 | 160 IF g#<>f#+1 THEN STOP 18 | 170 ENDFOR 19 | 180 CLOSE FILE 1 20 | 190 // 21 | 200 PRINT 22 | 210 PRINT "All ok" 23 | -------------------------------------------------------------------------------- /samples/tests/random2.lst: -------------------------------------------------------------------------------- 1 | 10 // RANDOM sample program 2 | 13 // This test has a dependency on the machine word size 3 | 16 // For 32-bit machines, 18 below must be replaced with 10 4 | 20 // 5 | 30 TRAP 6 | 40 DELETE "ofile7" 7 | 50 ENDTRAP 8 | 60 // 9 | 70 OPEN FILE 1, "ofile7", RANDOM 18 10 | 80 FOR f#:=1 TO 5 DO WRITE FILE 1,f#: 2*f#, 2*f#+1 11 | 90 CLOSE FILE 1 12 | 100 // 13 | 110 OPEN FILE 1, "ofile7", RANDOM 18 READ ONLY 14 | 120 TRAP 15 | 130 WRITE FILE 1,1: 8 16 | 140 STOP 17 | 150 HANDLER 18 | 160 PRINT "Expected error occurred: ";ERRTEXT$ 19 | 170 ENDTRAP 20 | 180 // 21 | 190 CLOSE 22 | 200 PRINT "All ok" 23 | -------------------------------------------------------------------------------- /samples/tests/read#1.lst: -------------------------------------------------------------------------------- 1 | 10 // READ FILE sample program 2 | 20 // 3 | 30 deliet("ofile11") 4 | 40 // 5 | 50 DIM a$(10) 6 | 60 // 7 | 70 FOR f:=1 TO 10 DO a$(f):="Number "+STR$(f) 8 | 80 // 9 | 90 OPEN FILE 1, "ofile11", WRITE 10 | 100 WRITE FILE 1: a$() 11 | 110 // 12 | 120 CLOSE FILE 1 13 | 130 // 14 | 140 a$:="" // Assignment of array 15 | 150 // 16 | 160 OPEN FILE 1, "ofile11", READ 17 | 170 READ FILE 1: a$() // READ FILE of array() 18 | 180 CLOSE 19 | 190 // 20 | 200 FOR f:=1 TO 10 DO 21 | 210 PRINT a$(f) 22 | 220 IF a$(f)<>"Number "+STR$(f) THEN STOP 23 | 230 ENDFOR 24 | 240 PRINT "All ok" 25 | 250 // 26 | 260 PROC deliet EXTERNAL "deliet.prc" 27 | -------------------------------------------------------------------------------- /samples/tests/read1.lst: -------------------------------------------------------------------------------- 1 | 10 // READ/DATA sample program 2 | 20 // 3 | 30 READ b, b$ 4 | 40 PRINT b 5 | 50 IF b<>5 THEN STOP 6 | 60 PRINT b$ 7 | 70 IF b$<>"Test READ/DATA" THEN STOP 8 | 80 // 9 | 90 PRINT "All ok" 10 | 100 // 11 | 110 DATA 5, "Test READ/DATA" 12 | -------------------------------------------------------------------------------- /samples/tests/read2.lst: -------------------------------------------------------------------------------- 1 | 10 // READ/DATA sample program 2 | 20 // 3 | 30 a:=1 4 | 40 a$:="Jos " 5 | 50 READ b, b$ 6 | 60 PRINT b 7 | 70 IF b<>2 THEN STOP 8 | 80 PRINT b$ 9 | 90 IF b$<>"Jos Visser" THEN STOP 10 | 100 // 11 | 110 PRINT "All ok" 12 | 120 // 13 | 130 DATA a+1, a$+"Visser" 14 | -------------------------------------------------------------------------------- /samples/tests/ref1.lst: -------------------------------------------------------------------------------- 1 | 10 // REF sample program 2 | 20 // 3 | 30 DIM reeks(3) 4 | 40 reeks:=8 5 | 50 a$:="a$" 6 | 60 aap(reeks, a$) 7 | 70 FOR f:=1 TO 3 DO 8 | 80 IF reeks(f)<>1 THEN STOP 9 | 90 ENDFOR 10 | 100 // 11 | 110 IF a$<>"b$" THEN STOP 12 | 120 // 13 | 130 PRINT "All ok" 14 | 140 // 15 | 150 PROC aap(REF a(), REF b$) 16 | 160 a:=1 17 | 170 b$:="b$" 18 | 180 ENDPROC 19 | -------------------------------------------------------------------------------- /samples/tests/repeat1.lst: -------------------------------------------------------------------------------- 1 | 10 // REPEAT/UNTIL sample program 2 | 20 // 3 | 30 i:=0 4 | 40 REPEAT 5 | 50 i:+1 6 | 60 UNTIL i>10 7 | 70 // 8 | 80 IF i<>11 THEN STOP 9 | 90 PRINT "All ok" 10 | -------------------------------------------------------------------------------- /samples/tests/repeat2.lst: -------------------------------------------------------------------------------- 1 | 10 DIM a$ OF 20 2 | 20 REPEAT a$:+"X" UNTIL LEN(a$)=20 3 | 30 REPEAT 4 | 40 PRINT a$ 5 | 50 IF LEN(a$)>1 THEN a$:=a$(2:) 6 | 60 UNTIL LEN(a$)=1 7 | 70 IF a$<>"X" THEN STOP "Not ok!" 8 | 80 PRINT "All ok" 9 | -------------------------------------------------------------------------------- /samples/tests/repeat3.lst: -------------------------------------------------------------------------------- 1 | 10 i:=1 2 | 20 REPEAT NULL UNTIL fun 3 | 30 IF i<>21 THEN STOP "Not ok" 4 | 40 PRINT "all ok" 5 | 50 // 6 | 60 FUNC fun 7 | 70 i:=i+1 8 | 80 RETURN i>20 9 | 90 ENDFUNC fun 10 | -------------------------------------------------------------------------------- /samples/tests/restore1.lst: -------------------------------------------------------------------------------- 1 | 10 // RESTORE sample program 2 | 20 // 3 | 30 base:=1 4 | 40 lees 5 | 50 RESTORE 6 | 60 base:=1 7 | 70 lees 8 | 80 RESTORE aap 9 | 90 base:=3 10 | 100 lees 11 | 110 // 12 | 120 PRINT "All ok" 13 | 130 // 14 | 140 DATA 1, 2 15 | 150 aap: 16 | 160 DATA 3, 4 17 | 170 // 18 | 180 PROC lees 19 | 190 WHILE NOT(EOD) DO 20 | 200 READ a 21 | 210 PRINT a 22 | 220 IF a<>base THEN STOP 23 | 230 base:+1 24 | 240 ENDWHILE 25 | 250 PRINT "--------" 26 | 260 ENDPROC 27 | -------------------------------------------------------------------------------- /samples/tests/retry1.lst: -------------------------------------------------------------------------------- 1 | 10 // RETRY test program 2 | 20 a:=0 3 | 30 ok:=FALSE 4 | 40 TRAP 5 | 50 PRINT 1/a 6 | 60 PRINT b 7 | 70 HANDLER 8 | 80 IF a=0 THEN 9 | 90 a:=2 10 | 100 RETRY 11 | 110 ELSE 12 | 120 PRINT "Expected other error occurred: ";ERRTEXT$ 13 | 130 ok:=TRUE 14 | 140 ENDIF 15 | 150 ENDTRAP 16 | 160 // 17 | 170 CASE ok OF 18 | 180 WHEN TRUE 19 | 190 PRINT "All ok" 20 | 200 OTHERWISE 21 | 210 PRINT "Not ok" 22 | 220 ENDCASE 23 | -------------------------------------------------------------------------------- /samples/tests/rnd()1.lst: -------------------------------------------------------------------------------- 1 | 10 // RND() sample program 2 | 20 // 3 | 30 DIM count#(0:1) 4 | 40 PAGE 5 | 50 PRINT "Count number of heads and tails" 6 | 60 PRINT "(Press system dependent ESCAPE key to end)" 7 | 70 // 8 | 80 WHILE TRUE DO 9 | 90 a#:=RND(1) 10 | 100 count#(a#):+1 11 | 110 CURSOR a#+4,1 12 | 120 PRINT count#(a#); 13 | 130 ENDWHILE 14 | -------------------------------------------------------------------------------- /samples/tests/rnd()2.lst: -------------------------------------------------------------------------------- 1 | 10 // RND() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Random number sum test" 5 | 50 PRINT "(Press ESCAPE to end)" 6 | 60 // 7 | 70 sum1:=0; sum2:=0 8 | 80 WHILE TRUE DO 9 | 90 num:=RND(0) 10 | 100 sum1:+num 11 | 110 sum2:+0.500000 12 | 120 CURSOR 4,1 13 | 130 PRINT sum1 14 | 140 PRINT sum2 15 | 150 PRINT ABS(sum1-sum2) 16 | 160 ENDWHILE 17 | -------------------------------------------------------------------------------- /samples/tests/rnd()3.lst: -------------------------------------------------------------------------------- 1 | 10 // Test of random generator 2 | 15 // Courtesy of Dick Klingens 3 | 20 // 4 | 30 maxend#:=8 5 | 40 FOR end#:=1 TO maxend# DO 6 | 50 nloop#:=0 7 | 60 REPEAT 8 | 70 nloop#:+1 9 | 80 k#:=RND(end#) 10 | 90 error#:=(k#>end#) 11 | 100 UNTIL error# OR nloop#=50000 12 | 110 13 | 120 PRINT "Passed value = ",end# 14 | 130 IF error# THEN 15 | 140 PRINT ">>> Unexpected value for RND(",end#,")" 16 | 150 PRINT " Value = ",k#, 17 | 155 STOP "Not ok" 18 | 160 ELSE 19 | 170 PRINT "No errors", 20 | 180 ENDIF 21 | 190 PRINT " after ",nloop#," loops" 22 | 200 ENDFOR end# 23 | 210 PRINT "All ok" 24 | 25 | -------------------------------------------------------------------------------- /samples/tests/rnd()4.lst: -------------------------------------------------------------------------------- 1 | 10 // Random number test program 2 | 20 // 3 | 30 PAGE 4 | 40 samples#:=100000 5 | 50 DIM a#(0:19) 6 | 60 FOR f#:=1 TO samples# DO 7 | 70 n:=INT(RND*100/5) 8 | 75 IF n=20 THEN n:=19 9 | 80 a#(n):+1 10 | 90 IF f# MOD 100=0 THEN update 11 | 100 ENDFOR f# 12 | 110 // 13 | 120 PROC update 14 | 130 LOCAL n#, k# 15 | 140 FOR n#:=1 TO 19 DO 16 | 150 CURSOR n#,1 17 | 160 PRINT USING "######": a#(n#); 18 | 170 PRINT " "; 19 | 180 FOR k#:=1 TO a#(n#) DIV 250 DO PRINT "*", 20 | 190 ENDFOR n# 21 | 200 CURSOR 22,1 22 | 210 PRINT "Samples so far: ";f#; 23 | 220 ENDPROC update 24 | -------------------------------------------------------------------------------- /samples/tests/rnd()5.lst: -------------------------------------------------------------------------------- 1 | 10 // Random number test program 2 | 20 // 3 | 30 PAGE 4 | 40 samples#:=100000 5 | 50 DIM a#(0:19) 6 | 60 FOR f#:=1 TO samples# DO 7 | 70 n:=RND(19) 8 | 80 a#(n):+1 9 | 90 IF f# MOD 100=0 THEN update 10 | 100 ENDFOR f# 11 | 110 // 12 | 120 PROC update 13 | 130 LOCAL n#, k# 14 | 140 FOR n#:=1 TO 19 DO 15 | 150 CURSOR n#,1 16 | 160 PRINT USING "######": a#(n#); 17 | 170 PRINT " "; 18 | 180 FOR k#:=1 TO a#(n#) DIV 250 DO PRINT "*", 19 | 190 ENDFOR n# 20 | 200 CURSOR 22,1 21 | 210 PRINT "Samples so far: ";f#; 22 | 220 ENDPROC update 23 | -------------------------------------------------------------------------------- /samples/tests/rnd()6.lst: -------------------------------------------------------------------------------- 1 | 10 // Random number test program 2 | 20 // 3 | 30 PAGE 4 | 40 samples#:=100000 5 | 50 DIM a#(-10:10) 6 | 60 FOR f#:=1 TO samples# DO 7 | 70 n:=RND(-10,10) 8 | 80 a#(n):+1 9 | 90 IF f# MOD 100=0 THEN update 10 | 100 ENDFOR f# 11 | 110 // 12 | 120 PROC update 13 | 130 LOCAL n#, k# 14 | 140 FOR n#:=-10 TO 10 DO 15 | 150 CURSOR n#+11,1 16 | 160 PRINT USING "######": a#(n#); 17 | 170 PRINT " "; 18 | 180 FOR k#:=1 TO a#(n#) DIV 250 DO PRINT "*", 19 | 190 ENDFOR n# 20 | 200 CURSOR 22,1 21 | 210 PRINT "Samples so far: ";f#; 22 | 220 ENDPROC update 23 | -------------------------------------------------------------------------------- /samples/tests/round1.lst: -------------------------------------------------------------------------------- 1 | 10 DIM dice(1:6) 2 | 20 dice():=0 3 | 30 FOR f#:=1 TO 100000 DO 4 | 40 a:=rand(1, 6) 5 | 50 dice(a):+1 6 | 60 ENDFOR f# 7 | 70 PRINT dice() 8 | 80 9 | 90 FUNC rand(x, y) 10 | 100 d:=RND 11 | 110 IF d<>FRAC(d) THEN STOP "Arfle barfle gloop?" 12 | 120 RETURN ROUND((y-x)*d+x) 13 | 130 ENDFUNC rand 14 | -------------------------------------------------------------------------------- /samples/tests/run1.lst: -------------------------------------------------------------------------------- 1 | 10 // RUN sample program 2 | 20 // 3 | 30 PRINT "Hello from run1" 4 | 40 RUN "run1a.sq" 5 | -------------------------------------------------------------------------------- /samples/tests/run1a.lst: -------------------------------------------------------------------------------- 1 | 10 // RUN sample program 2 | 20 // 3 | 30 PRINT "Hello from run1a" 4 | 40 PRINT "All ok" 5 | -------------------------------------------------------------------------------- /samples/tests/selin1.lst: -------------------------------------------------------------------------------- 1 | 10 // SELECT INPUT sample program 2 | 20 // 3 | 30 TRAP 4 | 40 SELECT INPUT "ofile" 5 | 50 FOR f:=1 TO 10 DO 6 | 60 INPUT a$ 7 | 70 PRINT a$ 8 | 80 IF a$<>"Output line "+STR$(f) THEN STOP 9 | 90 ENDFOR 10 | 100 SELECT INPUT "" 11 | 110 HANDLER 12 | 120 RUN "selout1.sq" 13 | 130 ENDTRAP 14 | 140 // 15 | 150 PRINT "All ok" 16 | -------------------------------------------------------------------------------- /samples/tests/selout1.lst: -------------------------------------------------------------------------------- 1 | 10 // SELECT OUTPUT sample program 2 | 20 // 3 | 30 TRAP 4 | 40 DELETE "ofile" 5 | 50 ENDTRAP 6 | 60 // 7 | 70 SELECT OUTPUT "ofile" 8 | 80 FOR f:=1 TO 10 DO 9 | 90 PRINT "Output line ",f 10 | 100 ENDFOR 11 | 110 SELECT OUTPUT "" 12 | 120 // 13 | 130 PRINT "Output written" 14 | 140 RUN "selin1.sq" 15 | -------------------------------------------------------------------------------- /samples/tests/sgn()1.lst: -------------------------------------------------------------------------------- 1 | 10 // SGN() sample program 2 | 20 // 3 | 30 IF SGN(-4.500000)<>-1 THEN STOP 4 | 40 IF SGN(4.600000)<>1 THEN STOP 5 | 50 IF SGN(0)<>0 THEN STOP 6 | 60 PRINT "All ok" 7 | -------------------------------------------------------------------------------- /samples/tests/signif1.lst: -------------------------------------------------------------------------------- 1 | 10 i:=1 2 | 20 REPEAT 3 | 30 i:=i/2 4 | 40 PRINT i 5 | 50 UNTIL i<0.000000 6 | 60 // 7 | 70 REPEAT 8 | 80 PRINT i 9 | 90 i:=i*2 10 | 100 UNTIL i>=1 11 | 110 // 12 | 120 PRINT "Final i = ";i 13 | 130 IF i<>1 THEN STOP 14 | 140 PRINT "All ok" 15 | -------------------------------------------------------------------------------- /samples/tests/sin()1.lst: -------------------------------------------------------------------------------- 1 | 10 // SIN() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Sinus" 5 | 50 FOR f:=0 TO 2*PI STEP PI/32 DO 6 | 60 plot(f, SIN(f)) 7 | 70 ENDFOR 8 | 80 // 9 | 90 CURSOR 23,1 10 | 100 PRINT "If the above looks like a sine wave, all might be ok" 11 | 110 // 12 | 120 PROC plot(x, y) 13 | 130 x#:=1+INT(x*10) 14 | 140 y#:=11+10*y 15 | 150 CURSOR y#,x# 16 | 160 PRINT "*"; 17 | 170 ENDPROC 18 | -------------------------------------------------------------------------------- /samples/tests/spc$.lst: -------------------------------------------------------------------------------- 1 | 10 // Jos' SPC$ function 2 | 20 // ------------------------------------- 3 | 30 FUNC my_spc$(n#) CLOSED 4 | 40 a$(n#:n#):=" " 5 | 50 RETURN a$ 6 | 60 ENDFUNC my_spc$ 7 | 70 // 8 | 80 b$:=SPC$(16384) 9 | 90 check(b$) 10 | 100 b$:=my_spc$(16384) 11 | 110 check(b$) 12 | 120 // 13 | 130 PROC check(REF b$) CLOSED 14 | 140 PRINT LEN(b$) 15 | 150 PRINT ">";b$(1:10);"< " 16 | 160 FOR f#:=1 TO LEN(b$) DO 17 | 170 IF b$(f#:f#)<>" " THEN STOP "Not ok!" 18 | 180 IF f# MOD 256=0 THEN PRINT "."; 19 | 190 ENDFOR f# 20 | 200 PRINT 21 | 210 ENDPROC 22 | 220 // 23 | 230 PRINT "All ok" 24 | -------------------------------------------------------------------------------- /samples/tests/spc$2.lst: -------------------------------------------------------------------------------- 1 | 10 // A recursive definition of SPC$ 2 | 20 // 3 | 30 FUNC hex$ EXTERNAL "hex.prc" 4 | 40 // 5 | 50 FUNC my_spc$(n#) CLOSED 6 | 60 IF SYS$(host)="UNIX" THEN 7 | 70 PRINT hex$(SYS(sbrk)) 8 | 80 ENDIF 9 | 90 IF n#=0 THEN RETURN "" 10 | 100 RETURN " "+my_spc$(n#-1) 11 | 110 ENDFUNC my_spc$ 12 | 120 13 | 130 k:=100 14 | 140 a$:=my_spc$(k) 15 | 150 PRINT LEN(a$) 16 | 160 IF LEN(a$)<>k THEN STOP "Not Ok" 17 | 170 PRINT "All ok" 18 | -------------------------------------------------------------------------------- /samples/tests/sq2lst.lst: -------------------------------------------------------------------------------- 1 | 10 // Convert all .SQ files to .LST 2 | 20 // 3 | 30 DIM filename$ OF 12 4 | 40 // 5 | 50 TRAP 6 | 60 DELETE "convert.in" 7 | 70 ENDTRAP 8 | 80 // 9 | 90 convert(".sq", ".lst") 10 | 100 convert(".prc", ".prl") 11 | 110 SYS sysin, "convert.in" 12 | 120 // 13 | 130 PROC convert(f$, t$) 14 | 140 CASE SYS$(host) OF 15 | 150 WHEN "MsDos" 16 | 160 PASS "dir *"+f$+" >temp" 17 | 170 WHEN "UNIX" 18 | 180 PASS "ls *"+f$+" >temp" 19 | 190 PASS "echo Finito >>temp" 20 | 200 OTHERWISE 21 | 210 PRINT "Unknown host" 22 | 220 STOP 23 | 230 ENDCASE 24 | 240 // 25 | 250 SELECT INPUT "temp" 26 | 260 // 27 | 270 REPEAT 28 | 280 INPUT filename$ 29 | 290 UNTIL f$ IN filename$ AND NOT("*" IN filename$) 30 | 300 // 31 | 310 SELECT OUTPUT "convert.in" 32 | 320 WHILE f$ IN filename$ DO 33 | 330 filename$:=filename$(1:f$ IN filename$-1) 34 | 340 PRINT "print \"";filename$ 35 | 350 PRINT "load \"";filename$;f$ 36 | 360 PRINT "list \"";filename$;t$ 37 | 370 INPUT filename$ 38 | 380 ENDWHILE 39 | 390 // 40 | 400 SELECT INPUT "" 41 | 410 SELECT OUTPUT "" 42 | 420 // 43 | 430 ENDPROC 44 | -------------------------------------------------------------------------------- /samples/tests/sqr()1.lst: -------------------------------------------------------------------------------- 1 | 10 // SQR() sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a, b 5 | 50 IF SQR(a)-b>0.000010 THEN STOP 6 | 60 ENDWHILE 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 DATA 1, 1, 2, 1.414210, 3, 1.732050, 4, 2, 9, 3, 16, 4, 25, 5, 625, 25, 100, 10 11 | -------------------------------------------------------------------------------- /samples/tests/stop1.lst: -------------------------------------------------------------------------------- 1 | 10 // STOP sample program 2 | 20 // 3 | 30 deliet("temp") 4 | 40 SELECT OUTPUT "temp" 5 | 50 PRINT "con" 6 | 60 SELECT OUTPUT "" 7 | 70 SYS sysin, "temp" 8 | 80 STOP 9 | 90 PRINT "Resumed" 10 | 100 PRINT "All ok" 11 | 110 // 12 | 120 PROC deliet EXTERNAL "deliet.prc" 13 | -------------------------------------------------------------------------------- /samples/tests/str$()1.lst: -------------------------------------------------------------------------------- 1 | 10 // STR$() sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a 5 | 50 PRINT "Number is >"+STR$(a)+"<" 6 | 60 ENDWHILE 7 | 70 // 8 | 80 DATA 1, -1, 4.500000, -7.800000, 1000, 0.000100, 20 9 | -------------------------------------------------------------------------------- /samples/tests/stringmul.lst: -------------------------------------------------------------------------------- 1 | 10 drawbox(60, 5) 2 | 20 // 3 | 30 PROC drawbox(x#, y#) CLOSED 4 | 40 PRINT "+","-"*(x#-2),"+" 5 | 50 FOR i#:=1 TO y#-2 DO 6 | 60 PRINT "|"," "*(x#-2),"|" 7 | 70 ENDFOR i# 8 | 80 PRINT "+","-"*(x#-2),"+" 9 | 90 ENDPROC drawbox 10 | -------------------------------------------------------------------------------- /samples/tests/substr1.lst: -------------------------------------------------------------------------------- 1 | 10 // Substring sample program 2 | 20 // 3 | 30 a$:="abcdefghijklmnopqrstuvwxyz" 4 | 40 // 5 | 50 IF a$(4:8)<>"defgh" THEN STOP 6 | 60 a$(4:8):="X" 7 | 70 IF a$<>"abcX ijklmnopqrstuvwxyz" THEN STOP 8 | 80 // 9 | 90 IF "Hallo"(1:2)<>"Ha" THEN STOP 10 | 100 IF aap$(1:2)<>"aa" THEN STOP 11 | 110 IF aap2$("AB")(2:3)<>"BA" THEN STOP 12 | 120 // 13 | 130 PRINT "All ok" 14 | 140 // 15 | 150 FUNC aap$ 16 | 160 RETURN "aap" 17 | 170 ENDFUNC 18 | 180 // 19 | 190 FUNC aap2$(a$) 20 | 200 RETURN a$+a$ 21 | 210 ENDFUNC 22 | -------------------------------------------------------------------------------- /samples/tests/substr2.lst: -------------------------------------------------------------------------------- 1 | 10 DIM a$ OF 26 2 | 20 DIM letter$(26) OF 1 3 | 30 FOR char#:=1 TO 26 DO 4 | 40 letter$(char#):=CHR$(char#+ORD("A")-1) 5 | 50 a$(:char#:):=letter$(char#) 6 | 60 ENDFOR char# 7 | 70 PRINT a$ 8 | 80 IF a$<>"ABCDEFGHIJKLMNOPQRSTUVWXYZ" THEN STOP "Not OK!" 9 | 90 PRINT "All ok" 10 | -------------------------------------------------------------------------------- /samples/tests/sys1.lst: -------------------------------------------------------------------------------- 1 | 10 // SYS, SYS() and SYS$() sample program 2 | 20 // 3 | 30 PRINT "PDComal version ";SYS(version) 4 | 40 PRINT "PDComal running under ";SYS$(host) 5 | 50 PRINT "Current interpreter is ";SYS$(interpreter) 6 | 60 // 7 | 70 PRINT "Internal debugging will be set to on" 8 | 80 SYS debug, on 9 | 90 PRINT "Een kleine test" 10 | 100 IF 1=2 THEN PRINT "processing testje" 11 | 110 SYS debug, off 12 | 120 // 13 | 130 PRINT "Short circuit boolean evaluation = ";SYS$(short_circuit) 14 | 140 PRINT "Showing the EXEC keyword in listings = ";SYS$(show_exec) 15 | 150 PRINT "Program trace is ";SYS$(prog_trace) 16 | -------------------------------------------------------------------------------- /samples/tests/tan()1.lst: -------------------------------------------------------------------------------- 1 | 10 // TAN() sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "Please stand by for tangent check" 5 | 50 FOR f:=0 TO 2*PI STEP PI/32 DO 6 | 60 CURSOR 4,1 7 | 70 PRINT USING "#.########": f; 8 | 80 d:=TAN(f)-SIN(f)/COS(f) 9 | 90 IF ABS(TAN(f))<1.0e+15 AND ABS(d)>0.0000001 THEN STOP 10 | 100 ENDFOR f 11 | 110 PRINT 12 | 120 PRINT "All ok" 13 | -------------------------------------------------------------------------------- /samples/tests/trace1.lst: -------------------------------------------------------------------------------- 1 | 10 // TRACE sample program 2 | 20 // 3 | 30 TRACE on 4 | 40 // These lines are traced 5 | 50 PRINT "Hello World" 6 | 60 TRACE off 7 | 70 // These lines are NOT traced 8 | 80 PRINT "Goodbye" 9 | -------------------------------------------------------------------------------- /samples/tests/trap1.lst: -------------------------------------------------------------------------------- 1 | 10 // TRAP ESC sample program 2 | 20 // 3 | 30 PAGE 4 | 40 PRINT "ESCAPE is now disabled, TRY IT!!" 5 | 50 TRAP ESC- 6 | 60 loopje(2) 7 | 70 PRINT 8 | 80 PRINT "ESCAPE is now enabled, TRY IT!!" 9 | 90 TRAP ESC+ 10 | 100 loopje(4) 11 | 110 PRINT 12 | 120 // 13 | 130 PROC loopje(y#) 14 | 140 FOR f#:=0 TO 500 DO 15 | 150 CURSOR y#,1 16 | 160 PRINT f#; 17 | 170 ENDFOR 18 | 180 ENDPROC 19 | -------------------------------------------------------------------------------- /samples/tests/trap2.lst: -------------------------------------------------------------------------------- 1 | 10 // TRAP/HANDLER/ENDTRAP sample program 2 | 20 // 3 | 30 TRAP 4 | 40 PRINT "1. Hello" 5 | 50 ENDTRAP 6 | 60 // 7 | 70 TRAP 8 | 80 PRINT "2. Hello" 9 | 90 PRINT 1/0 10 | 100 STOP 11 | 110 ENDTRAP 12 | 120 // 13 | 130 TRAP 14 | 140 PRINT "3. Hello" 15 | 150 HANDLER 16 | 160 STOP 17 | 170 ENDTRAP 18 | 180 // 19 | 190 TRAP 20 | 200 PRINT "4. Hello" 21 | 210 PRINT 1/0 22 | 220 HANDLER 23 | 230 PRINT "5. Hello" 24 | 240 PRINT " Error : ";ERR 25 | 250 PRINT " @ line : ";ERRLINE 26 | 260 PRINT " Errtext : ";ERRTEXT$ 27 | 270 ENDTRAP 28 | 280 // 29 | 290 PRINT "6. Hello" 30 | 300 // 31 | 310 PRINT "All ok" 32 | -------------------------------------------------------------------------------- /samples/tests/trap3.lst: -------------------------------------------------------------------------------- 1 | 10 // TRAP sample program 2 | 20 // 3 | 30 TRAP 4 | 40 aap 5 | 50 HANDLER 6 | 60 PRINT "Expected error occurred ";ERRTEXT$ 7 | 70 ENDTRAP 8 | 80 // 9 | 90 PRINT "All ok" 10 | 100 // 11 | 110 PROC olifant CLOSED 12 | 120 PRINT 1/0 13 | 130 ENDPROC 14 | 140 // 15 | 150 PROC aap CLOSED 16 | 170 olifant 17 | 180 ENDPROC 18 | -------------------------------------------------------------------------------- /samples/tests/true1.lst: -------------------------------------------------------------------------------- 1 | 10 // TRUE sample program 2 | 20 // 3 | 30 PRINT TRUE 4 | 40 PRINT 1=1 5 | 50 IF (1=1)<>TRUE THEN STOP 6 | 60 PRINT "All ok" 7 | -------------------------------------------------------------------------------- /samples/tests/using1.lst: -------------------------------------------------------------------------------- 1 | 10 // PRINT USING sample program 2 | 20 joesing("####", -10) 3 | 30 joesing("####", 4.500000) 4 | 40 joesing("#.##", 4.500000) 5 | 50 joesing("##.##", 4.500000) 6 | 60 joesing("#.#", 100.001000) 7 | 70 // 8 | 80 PROC joesing(format$, num) 9 | 90 PRINT format$;" >"; 10 | 100 PRINT USING format$: num; 11 | 110 PRINT "< ";num 12 | 120 ENDPROC 13 | -------------------------------------------------------------------------------- /samples/tests/val()1.lst: -------------------------------------------------------------------------------- 1 | 10 // VAL() sample program 2 | 20 // 3 | 30 WHILE NOT(EOD) DO 4 | 40 READ a$, b 5 | 50 IF VAL(a$)<>b THEN STOP 6 | 60 ENDWHILE 7 | 70 // 8 | 80 PRINT "All ok" 9 | 90 // 10 | 100 DATA "1", 1, "-1", -1, "4.5", 4.500000 11 | 110 DATA "1e2", 100, "0.2e2", 20 12 | -------------------------------------------------------------------------------- /samples/tests/while1.lst: -------------------------------------------------------------------------------- 1 | 10 // WHILE/ENDWHILE sample program 2 | 20 // 3 | 30 i:=10 4 | 40 WHILE i>0 DO i:-1 5 | 50 IF i<>0 THEN STOP 6 | 60 // 7 | 70 WHILE i<10 DO 8 | 80 i:+1 9 | 90 ENDWHILE 10 | 100 IF i<>10 THEN STOP 11 | 110 // 12 | 120 PRINT "All ok" 13 | -------------------------------------------------------------------------------- /samples/tests/write1.lst: -------------------------------------------------------------------------------- 1 | 10 // WRITE sample program 2 | 20 // 3 | 30 TRAP 4 | 40 DELETE "ofile8" 5 | 50 ENDTRAP 6 | 60 // 7 | 70 DIM a$(20) 8 | 80 FOR f:=1 TO 20 DO a$(f):="Number "+STR$(f) 9 | 90 f:-1 10 | 100 OPEN FILE 1, "ofile8", WRITE 11 | 110 WRITE FILE 1: f, a$() 12 | 120 CLOSE 13 | 130 // 14 | 140 OPEN FILE 1, "ofile8", READ 15 | 150 READ FILE 1: g 16 | 160 IF g<>20 THEN STOP 17 | 170 DIM b$(g) 18 | 180 READ FILE 1: b$ 19 | 190 CLOSE 20 | 200 // 21 | 210 FOR f:=1 TO g DO 22 | 220 IF b$(f)<>"Number "+STR$(f) THEN STOP 23 | 230 ENDFOR 24 | 240 // 25 | 250 PRINT "All ok" 26 | -------------------------------------------------------------------------------- /src/BUILD: -------------------------------------------------------------------------------- 1 | 727 2 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | .POSIX: 2 | .DELETE_ON_ERROR: 3 | 4 | # 5 | # OpenComal -- a free Comal implementation 6 | # 7 | # This file is part of the OpenComal package. 8 | # (c) Copyright 1992-2002 Jos Visser 9 | # 10 | # The OpenComal package is covered by the GNU General Public 11 | # License. See doc/LICENSE for more information. 12 | # 13 | 14 | SOURCES:=lex.yy.c pdccloop.c pdccmd.c pdcenv.c pdcexec.c pdcexp.c pdcext.c \ 15 | pdcfree.c pdcid.c pdclexs.c pdcunix.c pdclist.c pdcmain.c pdcmem.c \ 16 | pdcmisc.c pdcpars.tab.c pdcparss.c pdcprog.c pdcrun.c pdcscan.c \ 17 | pdcseg.c pdcsqash.c pdcstr.c pdcsym.c pdcval.c pdcmod.c long.c 18 | SOURCES_CII:=../cii/src/except.c ../cii/src/fmt.c 19 | SOURCES_NANA:=../nana/src/I.c 20 | 21 | TARG1:=../bin/opencomal 22 | OBJ1:=pdcpars.tab.o lex.yy.o pdcmain.o pdcmisc.o pdccmd.o pdclexs.o \ 23 | pdcid.o pdcscan.o pdcparss.o pdcenv.o pdcsym.o pdcexec.o pdclist.o \ 24 | pdcfree.o pdcexp.o pdcmem.o pdcsqash.o pdcstr.o pdcprog.o pdcext.o \ 25 | pdcseg.o pdcval.o pdccloop.o pdcmod.o long.o 26 | 27 | TARG2:=../bin/opencomalrun 28 | OBJ2:=pdcmain.o pdcmisc.o \ 29 | pdcid.o pdcscan.o pdcenv.o pdcsym.o pdcexec.o pdcfree.o \ 30 | pdcexp.o pdcmem.o pdcsqash.o pdcstr.o pdcprog.o pdcext.o pdcseg.o \ 31 | pdcval.o pdcrun.o pdcmod.o long.o 32 | OS:=pdcunix.o 33 | OBJ_CII:=../cii/src/except.o ../cii/src/fmt.o 34 | OBJ_NANA:=../nana/src/I.o 35 | 36 | ifdef DEBUG 37 | SOURCES_CII+=../cii/src/memchk.c ../cii/src/assert.c 38 | OBJ_CII+=../cii/src/memchk.o ../cii/src/assert.o 39 | CFLAGS+=-fsanitize=undefined 40 | LDFLAGS+=-fsanitize=undefined 41 | else 42 | SOURCES_CII+=../cii/src/mem.c 43 | OBJ_CII+=../cii/src/mem.o 44 | endif 45 | 46 | .PHONY: all 47 | all: build $(TARG1) $(TARG2) ../bin/en.cat ../bin/ga.cat 48 | 49 | # I recommend using c++ for compile-time warnings only, and building for release with the C compiler 50 | include $(REALCC).mk 51 | MKCATDEFS:=../tools/mkcatdefs 52 | include $(OPSYS).mk 53 | CFLAGS+=-I../cii/include -I. -I../nana/src 54 | MIN_CFLAGS:=$(CFLAGS) 55 | CFLAGS+=$(TARG_CFLAGS) 56 | SOURCE_DATE_EPOCH=$(shell git log -l --pretty=%ct) 57 | DATE_FMT = %Y-%m-%d 58 | ifdef SOURCE_DATE_EPOCH 59 | BUILD_DATE ?= $(shell date -u -d "@$(SOURCE_DATE_EPOCH)" "+$(DATE_FMT)" 2>/dev/null || date -u -r "$(SOURCE_DATE_EPOCH)" "+$(DATE_FMT)" 2>/dev/null || date -u "+$(DATE_FMT)") 60 | else 61 | BUILD_DATE ?= $(shell date "+$(DATE_FMT)") 62 | endif 63 | CFLAGS+='-DBUILD_DATE="$(BUILD_DATE)"' 64 | 65 | $(OBJ1) $(OBJ2) $(OS): pdcpars.tab.h 66 | 67 | $(TARG1): $(OBJ1) $(OS) $(OBJ_CII) $(OBJ_NANA) 68 | $(CC) -o $(TARG1) $(OBJ1) $(OS) $(OBJ_CII) $(OBJ_NANA) $(LDFLAGS) $(TARG_LDFLAGS) 69 | 70 | $(TARG2): $(OBJ2) $(OS) $(OBJ_CII) $(OBJ_NANA) 71 | $(CC) -o $(TARG2) $(OBJ2) $(OS) $(OBJ_CII) $(OBJ_NANA) $(LDFLAGS) $(TARG_LDFLAGS) 72 | 73 | .PHONY: build 74 | build: 75 | ../tools/bumpbuild BUILD 76 | ../tools/genversion 77 | 78 | YFLAGS:=-vd -b pdcpars 79 | pdcpars.tab.c: pdcpars.y 80 | $(YACC) $(YFLAGS) pdcpars.y 81 | 82 | pdcpars.tab.h: pdcpars.tab.c 83 | 84 | LFLAGS:=-X 85 | lex.yy.c: pdclex.l 86 | $(LEX) $(LFLAGS) pdclex.l 87 | 88 | pdcpars.tab.o: msgnrs.h 89 | 90 | .PHONY: almostclean 91 | almostclean: 92 | $(RM) *.o *.obj *.map *.OBJ *~ *.d $(OBJ_CII) $(OBJ_NANA) 93 | $(RM) lex.yy.c pdcpars.tab.* pdcpars.output 94 | $(RM) pdcpars.c pdclex.c pdcpars.h 95 | 96 | .PHONY: clean 97 | clean: almostclean 98 | $(RM) $(TARG1) $(TARG2) 99 | $(RM) ../bin/*.exe ../bin/*.EXE ../bin/*.cat 100 | $(RM) $(MKCATDEFS) 101 | 102 | DEPS := $(SOURCES:%.c=%.o.d) 103 | -include $(DEPS) 104 | -------------------------------------------------------------------------------- /src/Makefile.bak: -------------------------------------------------------------------------------- 1 | # 2 | # OpenComal -- a free Comal implementation 3 | # 4 | # This file is part of the OpenComal package. 5 | # (c) Copyright 1992-2002 Jos Visser 6 | # 7 | # The OpenComal package is covered by the GNU General Public 8 | # License. See doc/LICENSE for more information. 9 | # 10 | 11 | TARG1=../bin/opencomal 12 | OBJ1=pdcpars.tab.o lex.yy.o pdcmain.o pdcmisc.o pdccmd.o pdclexs.o \ 13 | pdcid.o pdcscan.o pdcparss.o pdcenv.o pdcsym.o pdcexec.o pdclist.o \ 14 | pdcfree.o pdcexp.o pdcmem.o pdcsqash.o pdcstr.o pdcprog.o pdcext.o \ 15 | pdcseg.o pdcval.o pdccloop.o 16 | 17 | TARG2=../bin/opencomalrun 18 | OBJ2=pdcmain.o pdcmisc.o \ 19 | pdcid.o pdcscan.o pdcenv.o pdcsym.o pdcexec.o pdcfree.o \ 20 | pdcexp.o pdcmem.o pdcsqash.o pdcstr.o pdcprog.o pdcext.o pdcseg.o \ 21 | pdcval.o pdcrun.o 22 | OS=pdclinux.o 23 | OSLIB=-lncurses -lreadline 24 | STATIC= 25 | #PROFILE=-pg 26 | PROFILE= 27 | 28 | COPTS=-c -ggdb -pedantic -Wall -DOS_LINUX $(PROFILE) 29 | LIBS=-lm $(OSLIB) 30 | 31 | LDOPTS=$(STATIC) $(LIBS) 32 | 33 | all: build $(TARG1) $(TARG2) 34 | 35 | $(TARG1): $(OBJ1) $(OS) 36 | gcc $(PROFILE) -o $(TARG1) $(OBJ1) $(OS) $(LDOPTS) 37 | 38 | $(TARG2): $(OBJ2) $(OS) 39 | gcc $(PROFILE) -o $(TARG2) $(OBJ2) $(OS) $(LDOPTS) 40 | 41 | build: 42 | ../tools/bumpbuild BUILD 43 | ../tools/genversion 44 | 45 | pdcpars.tab.c: pdcpars.y 46 | bison -vd pdcpars.y 47 | 48 | lex.yy.c: pdclex.l 49 | flex pdclex.l 50 | 51 | almostclean: 52 | -rm *.o *.obj *.map *.OBJ *~ 53 | -rm lex.yy.c pdcpars.tab.* pdcpars.output 54 | -rm pdcpars.c pdclex.c pdcpars.h 55 | 56 | clean: almostclean 57 | -rm $(TARG1) $(TARG2) 58 | -rm ../bin/*.exe ../bin/*.EXE 59 | 60 | .c.o: 61 | gcc $(COPTS) $*.c 62 | # DO NOT DELETE 63 | 64 | pdcpars.o: pdcglob.h pdcconst.h pdcsys.h pdcdsys.h pdcdef.h 65 | pdcpars.o: /usr/include/stdio.h /usr/include/features.h 66 | pdcpars.o: /usr/include/sys/cdefs.h /usr/include/gnu/stubs.h 67 | pdcpars.o: /usr/lib/gcc-lib/i586-pc-linux-gnu/2.95.3/include/stddef.h 68 | pdcpars.o: /usr/include/bits/types.h /usr/include/libio.h 69 | pdcpars.o: /usr/include/_G_config.h /usr/include/wchar.h 70 | pdcpars.o: /usr/include/bits/wchar.h /usr/include/gconv.h 71 | pdcpars.o: /usr/lib/gcc-lib/i586-pc-linux-gnu/2.95.3/include/stdarg.h 72 | pdcpars.o: /usr/include/bits/stdio_lim.h pdcmem.h pdcerr.h pdcmsg.h pdcfunc.h 73 | pdcpars.o: /usr/include/stdlib.h /usr/include/setjmp.h 74 | pdcpars.o: /usr/include/bits/setjmp.h /usr/include/bits/sigset.h pdcparss.h 75 | pdcpars.o: pdcmisc.h pdcid.h pdcprog.h /usr/include/string.h 76 | -------------------------------------------------------------------------------- /src/VERSION: -------------------------------------------------------------------------------- 1 | 0.3.0 2 | -------------------------------------------------------------------------------- /src/compat_cdefs.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Wrapper around BSD sys/cdefs.h annotations 13 | * 14 | * @todo 15 | * - __pure 16 | * - __used 17 | * - __warn_unused_result 18 | * - __bounded 19 | * - __returns_twice 20 | * - __only_inline 21 | * - __packed 22 | * - __aligned 23 | * - __dso_public N/A 24 | * - __dso_hidden N/A 25 | */ 26 | 27 | #ifndef COMPAT_CDEFS_H 28 | #define COMPAT_CDEFS_H 29 | 30 | #ifdef __APPLE__ 31 | #include 32 | #define __my_unused __unused 33 | #else 34 | 35 | #include 36 | 37 | #ifndef __dead 38 | #define __dead \ 39 | __attribute__((__noreturn__)) 40 | #endif 41 | 42 | #ifndef __my_unused 43 | #define __my_unused \ 44 | __attribute__((unused)) 45 | #endif 46 | 47 | #endif // __APPLE__ 48 | 49 | #ifndef __malloc 50 | #define __malloc \ 51 | __attribute__((__malloc__)) 52 | #endif 53 | 54 | #endif 55 | -------------------------------------------------------------------------------- /src/en.msg: -------------------------------------------------------------------------------- 1 | $ Messages for the OpenCOMAL interpreter. 2 | $quote " 3 | 4 | $set Main 5 | NewlocaleFailed "warning: Setting locale failed.\nwarning: Please check that the locale \"%s\" is supported and installed on your system.\nwarning: Falling back to the global locale (\"%s\").\n" 6 | BadOpt "Unrecognised option: '-%c'\n" 7 | Usage "usage: %s [-dy] [-m ] ...\n" 8 | Copyright " (c) Copyright 1992-2002 Jos Visser " 9 | Banner "OpenComal -- A free Comal implementation (version %s; %s; build %s)" 10 | Built " Last modified on " 11 | Lic1 "OpenComal is licensed under the GNU General Public License (GPL) version 3" 12 | Lic2 "(The GPL contains a very nice statement on WARRANTY; you might want to read it)" 13 | ReqOp "Option -%c requires an operand\n" 14 | 15 | $set CLoop 16 | HaltedPrompt "(halted)$ " 17 | 18 | $set Exec 19 | Stopped "OpenComal's warp engines answered full stop" 20 | Sure "Are you sure? " 21 | InputEsc "Escape from INPUT" 22 | CantExit "Can't EXIT in direct mode (use BYE to leave OpenCOMAL)" 23 | 24 | $set Misc 25 | NotSaved "Latest changes have not yet been saved! Proceed? " 26 | EnvUnsaved "Environment %s contains unsaved changes!" 27 | Proceed "Proceed? " 28 | 29 | $set UNIX 30 | No "No\n" 31 | Yes "Yes\n" 32 | 33 | $set Scan 34 | CurExec "the current execution line" 35 | CurData "the current DATA line" 36 | StrucLine "a program structure line" 37 | InhibCon "Adding/Modifying/Deleting %s has inhibited CONtinuation" 38 | 39 | $set Pars 40 | SynErr "Syntax error" 41 | 42 | $set Common 43 | Escape "Escape" 44 | -------------------------------------------------------------------------------- /src/ga.msg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/poldy/OpenCOMAL/a4c4aa8641d4d8a30ef47de65e1a9b6b9a4f78ca/src/ga.msg -------------------------------------------------------------------------------- /src/gcc.mk: -------------------------------------------------------------------------------- 1 | CC:=../build/ccd-gcc 2 | CFLAGS+=-Wall -Wextra -D_FORTIFY_SOURCE=2 3 | ifdef DEBUG 4 | CFLAGS+=-O0 -ggdb 5 | #LDFLAGS+=-lefence 6 | else 7 | CFLAGS+=-DNDEBUG -Os 8 | LDFLAGS+=-Os 9 | ifeq ($(OPSYS),macos) 10 | CFLAGS+=-flto 11 | LDFLAGS+=-flto 12 | else 13 | CFLAGS+=-flto=jobserver 14 | LDFLAGS+=-flto=jobserver 15 | endif 16 | endif 17 | ifeq ($(REALCC),gcc) 18 | CFLAGS+=-std=c11 19 | endif 20 | -------------------------------------------------------------------------------- /src/header: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | -------------------------------------------------------------------------------- /src/linux.mk: -------------------------------------------------------------------------------- 1 | -include /usr/share/hardening-includes/hardening.make 2 | CFLAGS += $(HARDENING_CFLAGS) 3 | LDFLAGS += $(HARDENING_LDFLAGS) 4 | TARG_CFLAGS:=$(shell ncursesw5-config --cflags) 5 | TARG_LDFLAGS:=-lreadline -lm $(shell ncursesw5-config --libs) 6 | ../bin/%.cat: %.msg 7 | LANG=ga_IE@euro gencat -H msgnrs.h -o $@ $^ 8 | 9 | msgnrs.h: ../bin/en.cat 10 | -------------------------------------------------------------------------------- /src/long.c: -------------------------------------------------------------------------------- 1 | #define _XOPEN_SOURCE 700 2 | 3 | #include 4 | #include "compat_cdefs.h" 5 | 6 | #include "long.h" 7 | 8 | void 9 | cvt_D(int code __my_unused, va_list_box * box, 10 | int put(int c, void *cl), void *cl, 11 | unsigned char flags[], int width, int precision) 12 | { 13 | long val = va_arg(box->ap, long); 14 | unsigned long m; 15 | char buf[43]; 16 | char *p = buf + sizeof buf; 17 | if (val == LONG_MIN) 18 | m = LONG_MAX + 1U; 19 | else if (val < 0) 20 | m = -val; 21 | else 22 | m = val; 23 | do 24 | *--p = m % 10 + '0'; 25 | while ((m /= 10) > 0); 26 | if (val < 0) 27 | *--p = '-'; 28 | Fmt_putd(p, (buf + sizeof buf) - p, put, cl, flags, width, precision); 29 | } 30 | -------------------------------------------------------------------------------- /src/long.h: -------------------------------------------------------------------------------- 1 | #ifndef LONG_H 2 | #define LONG_H 3 | 4 | #include "fmt.h" 5 | 6 | void cvt_D(int code, va_list_box * box, 7 | int put(int c, void *cl), void *cl, 8 | unsigned char flags[], int width, int precision); 9 | 10 | #endif 11 | -------------------------------------------------------------------------------- /src/macos.mk: -------------------------------------------------------------------------------- 1 | TARG_CFLAGS+=-I/usr/local/opt/readline/include 2 | TARG_LDFLAGS:=-L/usr/local/opt/readline/lib -lreadline -lncurses -liconv 3 | ../bin/%.cat: %.tmp 4 | LANG=en_GB.ISO8859-15 gencat $@ $^ 5 | 6 | %.tmp: %.msg 7 | LANG=en_GB.ISO8859-15 $(MKCATDEFS) msgnrs.h $(filter-out $(MKCATDEFS),$^) > $@ 8 | 9 | mkcatdefs.o: ../tools/mkcatdefs.c 10 | $(CC) $(MIN_CFLAGS) -c $^ 11 | 12 | $(MKCATDEFS): mkcatdefs.o $(OBJ_CII) 13 | $(CC) $(LDFLAGS) -o $@ $^ 14 | strip $@ 15 | 16 | msgnrs.h: en.tmp 17 | 18 | en.tmp: $(MKCATDEFS) 19 | -------------------------------------------------------------------------------- /src/pdccloop.c: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /* 12 | * Main file of OpenComal Command loop 13 | */ 14 | 15 | #define _XOPEN_SOURCE 700 16 | 17 | #include 18 | #include 19 | #include "pdcnana.h" 20 | #include "pdcglob.h" 21 | #include "pdcsym.h" 22 | #include "pdcmisc.h" 23 | #include "pdcparss.h" 24 | #include "pdcprog.h" 25 | #include "pdccmd.h" 26 | #include "pdcexec.h" 27 | #include "pdclexs.h" 28 | #include "pdcenv.h" 29 | #include "msgnrs.h" 30 | #include "pdccloop.h" 31 | 32 | PUBLIC const char * 33 | sys_interpreter(void) 34 | { 35 | return "OpenComal"; 36 | } 37 | 38 | 39 | PUBLIC bool 40 | process_comal_line(struct comal_line *line) 41 | { 42 | bool result = false; 43 | 44 | if (!line) 45 | return false; 46 | 47 | if (line->cmd >= 0) { 48 | if (line->ld) { 49 | prog_addline(line); 50 | mem_shiftmem(PARSE_POOL, curenv->program_pool); 51 | } else if (line->cmd != 0) { 52 | if (setjmp(ERRBUF) == 0) 53 | if (!cmd_exec(line, &result)) { 54 | if (!curenv->curenv) 55 | curenv->curenv = ROOTENV(); 56 | 57 | exec_line(line); 58 | } 59 | 60 | give_run_err(NULL); 61 | } 62 | } 63 | 64 | mem_freepool(PARSE_POOL); 65 | return result; 66 | } 67 | 68 | 69 | PUBLIC struct comal_line * 70 | crunch_line(char *line) 71 | { 72 | extern struct comal_line c_line; 73 | struct comal_line *work; 74 | 75 | while (true) { 76 | int rc; 77 | int errpos; 78 | 79 | lex_setinput(line); 80 | rc = yyparse(); 81 | 82 | if (rc) 83 | pars_error("Arfle Barfle Gloop?"); 84 | 85 | errpos = pars_handle_error(); 86 | 87 | if (!errpos) { 88 | work = stat_dup(&c_line); 89 | 90 | return work; 91 | } 92 | 93 | remove_trailing(line, "\n", ""); 94 | remove_trailing(line, "\r", ""); 95 | 96 | if (sys_edit(MSG_DIALOG, line, MAX_LINELEN)) { 97 | my_printf(MSG_DIALOG, true, "%s", 98 | catgets(catdesc, CommonSet, CommonEscape, "Escape")); 99 | return NULL; 100 | } 101 | } 102 | } 103 | 104 | 105 | PUBLIC void 106 | comal_loop(int newstate) 107 | { 108 | char line[MAX_LINELEN]; 109 | struct comal_line *aline; 110 | jmp_buf save_err; 111 | const char *prompt = "$ "; 112 | bool ret = false; 113 | 114 | curenv->running = newstate; 115 | memcpy(save_err, ERRBUF, sizeof(jmp_buf)); 116 | 117 | do { 118 | if (curenv->running == HALTED) 119 | prompt = 120 | catgets(catdesc, CLoopSet, CLoopHaltedPrompt, 121 | "(halted)$ "); 122 | 123 | if (!sys_get(MSG_DIALOG, line, MAX_LINELEN, prompt)) { 124 | aline = crunch_line(line); 125 | ret = process_comal_line(aline); 126 | 127 | if (curenv->con_inhibited) { 128 | curenv->con_inhibited = false; 129 | longjmp(RESTART, JUST_RESTART); 130 | } 131 | } else 132 | my_printf(MSG_DIALOG, true, "%s", 133 | catgets(catdesc, CommonSet, CommonEscape, "Escape")); 134 | } while (!ret); 135 | 136 | curenv->running = RUNNING; 137 | memcpy(ERRBUF, save_err, sizeof(jmp_buf)); 138 | } 139 | 140 | 141 | PUBLIC void 142 | pdc_go(int argc __my_unused, char *argv[]__my_unused) 143 | { 144 | int restart_err; 145 | 146 | restart_err = setjmp(RESTART); 147 | 148 | DBG_PRINTF(true, "Interpreter restart code: %d", restart_err); 149 | 150 | if (restart_err == PROG_END) 151 | clean_runenv(curenv); 152 | 153 | if (restart_err == RUN) 154 | prog_run(); 155 | 156 | if (restart_err != QUIT) 157 | comal_loop(CMDLOOP); 158 | } 159 | -------------------------------------------------------------------------------- /src/pdccloop.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal MAIN command loop header file 13 | */ 14 | 15 | #ifndef PDCCLOOP_H 16 | #define PDCCLOOP_H 17 | 18 | /** Return the interpreter name */ 19 | extern const char *sys_interpreter(void); 20 | 21 | /** Process one line of input into the interpreter, either a command or a program line */ 22 | extern bool process_comal_line(struct comal_line *line); 23 | 24 | /** Parse a program line */ 25 | extern struct comal_line *crunch_line(char *line); 26 | 27 | /** Main loop of interpreter, get a line and parse or execute it */ 28 | extern void comal_loop(int newstate); 29 | 30 | /** Entry point for development environment, including error handlers */ 31 | extern void pdc_go(int argc, char **argv); 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /src/pdccmd.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Processing of the interpreters direct commands 13 | */ 14 | 15 | #ifndef PDCCMD_H 16 | #define PDCCMD_H 17 | 18 | /** Scan all of the entered program */ 19 | extern bool cmd_scan(struct comal_line *line); 20 | 21 | /** Execute a command */ 22 | extern bool cmd_exec(struct comal_line *line, bool *result); 23 | 24 | #endif 25 | -------------------------------------------------------------------------------- /src/pdcconst.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal, various not-implementation defined constants 13 | */ 14 | 15 | #ifndef PDCCONST_H 16 | #define PDCCONST_H 17 | 18 | #define MAX_LINELEN (256) /**< Max line length for input etc. */ 19 | #define MAX_IDLEN (31) 20 | #define MAX_INDENT (16) /**< Max nesting of control structures */ 21 | #define INDENTION (2) /**< Indention per nesting */ 22 | #define DEFAULT_STRLEN (INT_MAX) 23 | #define DEFAULT_DIMBOTTOM (1) 24 | #define SQASH_BUFSIZE (32767) /**< For save/load buffer */ 25 | #define TEXT_BUFSIZE (32767) /**< For list/enter buffer */ 26 | #define OCOMAL_PATH_MAX (256) /**< Because pgcc can't find PATH_MAX */ 27 | 28 | #endif 29 | -------------------------------------------------------------------------------- /src/pdcdsys.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal SYS routines. 13 | * This is the OS abstraction layer. 14 | */ 15 | 16 | #ifndef PDCDSYS_H 17 | #define PDCDSYS_H 18 | 19 | #include "pdcdef.h" 20 | 21 | #include 22 | #include 23 | 24 | /** Initialise the OS support layer */ 25 | extern void sys_init(void); 26 | 27 | /** Cleanup the OS support layer before exiting */ 28 | extern void sys_tini(void); 29 | 30 | /** Generate a random number */ 31 | extern void sys_rand(long *result, long *scale); 32 | 33 | /** Randomizes the random number generator */ 34 | extern void sys_randomize(long seed); 35 | 36 | /** Test whether or not the escape (^C) key has been pressed */ 37 | extern bool sys_escape(void); 38 | 39 | /** Output a string to a stream */ 40 | extern void sys_put(int stream, const char *buf, long len); 41 | 42 | /** Clear the screen */ 43 | extern void sys_page(FILE * f); 44 | 45 | /** Erase the current line to the right of the cursor to the end of the current line */ 46 | extern void sys_clrtoeol(FILE * f); 47 | 48 | /** Turn on reverse video */ 49 | extern void sys_rvson(FILE * f); 50 | 51 | /** Turn off reverse video */ 52 | extern void sys_rvsoff(FILE * f); 53 | 54 | /** Pass a command to the OS command interpreter */ 55 | extern int sys_system(char *cmd); 56 | 57 | /** Configure text output to wait for a key to be pressed after each screenful */ 58 | extern void sys_setpaged(int flag); 59 | 60 | /** Move the cursor to the specified location */ 61 | extern void sys_cursor(FILE * f, long y, long x); 62 | 63 | /** Returns the current column position of the cursor on the text screen */ 64 | extern int sys_curcol(void); 65 | 66 | /** Returns the current row of the text screen that the cursor is on */ 67 | extern int sys_currow(void); 68 | 69 | /** Output a newline */ 70 | extern void sys_nl(void); 71 | 72 | /** Move the cursor to the next tab stop */ 73 | extern void sys_ht(void); 74 | 75 | /** Get the current tab stop interval */ 76 | extern long sys_zone_num(void); 77 | 78 | /** Set the tab stop interval */ 79 | extern void sys_zone(long size); 80 | 81 | /** Get a yes or no answer to a question */ 82 | extern bool sys_yn(int stream, const char *s); 83 | 84 | /** Get a line of text */ 85 | extern bool sys_get(int stream, char *line, int maxlen, 86 | const char *prompt); 87 | 88 | /** Edit a line of text */ 89 | extern bool sys_edit(int stream, char *line, int maxlen); 90 | 91 | /** Get the current working directory */ 92 | extern char *sys_dir_string(void); 93 | 94 | /** Print a directory listing */ 95 | extern void sys_dir(const char *pattern); 96 | 97 | /** Get the drive letter/number */ 98 | extern const char *sys_unit_string(void); 99 | 100 | /** Return a string containing enough spaces to get to a column */ 101 | extern const char *sys_tab_string(long col); 102 | 103 | /** Set the drive letter/number */ 104 | extern void sys_unit(char *unit); 105 | 106 | /** Change the current working directory */ 107 | extern void sys_chdir(char *dir); 108 | 109 | /** Remove a directory */ 110 | extern void sys_rmdir(char *dir); 111 | 112 | /** Create a directory */ 113 | extern void sys_mkdir(char *dir); 114 | 115 | /** Get one keypress */ 116 | extern char *sys_key(long delay); 117 | 118 | /** Evaluation a SYS(arg) expression */ 119 | extern void sys_sys_exp(struct exp_list *exproot, void **result, enum 120 | VAL_TYPE *type); 121 | 122 | /** Evaluation a SYS$(arg) expression */ 123 | extern void sys_syss_exp(struct exp_list *exproot, 124 | struct string **result, enum 125 | VAL_TYPE *type); 126 | 127 | /** Evaluate a "SYS arg" statement */ 128 | extern int sys_sys_stat(struct exp_list *exproot); 129 | 130 | #endif 131 | -------------------------------------------------------------------------------- /src/pdcenv.c: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /* 12 | * OpenComal Environment management 13 | */ 14 | 15 | #define _XOPEN_SOURCE 700 16 | 17 | #include "pdcnana.h" 18 | #include "pdcglob.h" 19 | #include "pdcmisc.h" 20 | #include "pdcstr.h" 21 | #include "pdcseg.h" 22 | #include "pdcid.h" 23 | #include "pdcmod.h" 24 | #include "pdcsym.h" 25 | #include "pdcenv.h" 26 | #include 27 | #include 28 | 29 | PUBLIC struct comal_env * 30 | env_new(const char *name) 31 | { 32 | struct comal_env *work = GETCORE(MISC_POOL, struct comal_env); 33 | struct env_list *work2 = GETCORE(MISC_POOL, struct env_list); 34 | 35 | work->progroot = NULL; 36 | work->segroot = NULL; 37 | work->envname = my_strdup(MISC_POOL, name); 38 | work->scan_ok = false; 39 | work->rootenv = NULL; 40 | work->curenv = NULL; 41 | work->changed = false; 42 | work->name = NULL; 43 | work->curline = NULL; 44 | work->trace = 0; 45 | work->error = 0; 46 | work->errmsg = NULL; 47 | work->errline = NULL; 48 | work->datalptr = NULL; 49 | work->dataeptr = NULL; 50 | work->con_inhibited = false; 51 | work->running = 0; 52 | work->fileroot = NULL; 53 | work->lasterr = 0; 54 | work->lasterrmsg = NULL; 55 | work->errline = 0; 56 | work->escallowed = true; 57 | work->nrtraps = 0; 58 | work->program_pool = pool_new(); 59 | 60 | work2->next = env_root; 61 | env_root = work2; 62 | work2->env = work; 63 | 64 | return work; 65 | } 66 | 67 | PUBLIC struct comal_env * 68 | env_find(char *name) 69 | { 70 | struct env_list *walk = env_root; 71 | 72 | while (walk) { 73 | if (strcmp(walk->env->envname, name) == 0) 74 | break; 75 | 76 | walk = walk->next; 77 | } 78 | 79 | if (walk) 80 | return walk->env; 81 | 82 | my_printf(MSG_DIALOG, true, "Creating new environment %s", name); 83 | 84 | return env_new(name); 85 | } 86 | 87 | 88 | PUBLIC void 89 | clean_runenv(struct comal_env *env) 90 | { 91 | struct file_rec *fwalk = curenv->fileroot; 92 | struct comal_line *walk; 93 | 94 | DBG_PRINTF(true, "Cleaning runenv"); 95 | 96 | /* 97 | * Free all the existing static environments of procedures, functions 98 | * and modules. 99 | */ 100 | FOR_EACH_LINE(NULL, walk) 101 | if (walk->cmd == procSYM || walk->cmd == funcSYM 102 | || walk->cmd == moduleSYM) 103 | if (walk->lc.pfrec.staticenv) { 104 | sym_freeenv(walk->lc.pfrec.staticenv, 0); 105 | walk->lc.pfrec.staticenv = NULL; 106 | } 107 | 108 | env->lasterr = 0; 109 | mem_free(env->lasterrmsg); 110 | env->lasterrmsg = NULL; 111 | env->errline = 0; 112 | env->escallowed = true; 113 | env->nrtraps = 0; 114 | env->running = 0; 115 | env->curenv = NULL; 116 | 117 | env->datalptr = NULL; 118 | env->dataeptr = NULL; 119 | 120 | /* 121 | * Close all open files 122 | */ 123 | while (fwalk) { 124 | DBG_PRINTF(true, "Closing comal file %D", fwalk->cfno); 125 | 126 | fclose(fwalk->hfptr); 127 | fwalk = fwalk->next; 128 | } 129 | 130 | curenv->fileroot = NULL; 131 | 132 | mod_freeall(); 133 | seg_allfree(); 134 | mem_freepool(RUN_POOL); 135 | } 136 | 137 | 138 | PUBLIC void 139 | clear_env(struct comal_env *env) 140 | { 141 | clean_runenv(env); 142 | 143 | env->progroot = NULL; 144 | env->rootenv = NULL; 145 | env->changed = false; 146 | env->scan_ok = false; 147 | 148 | mem_free(env->name); 149 | 150 | env->name = NULL; 151 | } 152 | -------------------------------------------------------------------------------- /src/pdcenv.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal environment handling header file 13 | */ 14 | 15 | #ifndef PDCENV_H 16 | #define PDCENV_H 17 | 18 | /** Create a new environment */ 19 | extern struct comal_env *env_new(const char *name); 20 | 21 | /** Return a named environment */ 22 | extern struct comal_env *env_find(char *name); 23 | 24 | /** Return the current program to its initial state */ 25 | extern void clean_runenv(struct comal_env *env); 26 | 27 | /** Totally clear an environment, including the current program */ 28 | extern void clear_env(struct comal_env *env); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /src/pdcerr.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal Comal error codes 13 | */ 14 | 15 | #ifndef PDCERR_H 16 | #define PDCERR_H 17 | 18 | /* 19 | * Run error codes 20 | */ 21 | 22 | #define NO_RUN_ERR 0 23 | #define LABEL_ERR 1 /**< Label not found */ 24 | #define DATA_ERR 2 /**< No DATA statements found */ 25 | #define DEL_ERR 3 /**< Delete "file" failed */ 26 | #define NORETURN_ERR 4 /**< ENDFUNC without RETURN */ 27 | #define DIRECT_ERR 5 /**< Error when executing simple_stat in direct mode */ 28 | #define F2INT1_ERR 6 /**< floating point too large to convert to int */ 29 | #define F2INT2_ERR 7 /**< floating point contains frac part */ 30 | #define VAL_ERR 8 /**< VAL() failed */ 31 | #define CHR_ERR 9 /**< CHR$() of <0 || >255 */ 32 | #define DIV0_ERR 10 /**< Division by 0 */ 33 | #define OS_ERR 12 /**< OS command error */ 34 | #define NIMP_ERR 13 /**< Not yet implemented error */ 35 | #define VAR_ERR 14 /**< Variable exists already */ 36 | #define DIM_ERR 15 /**< Top dimension larger then bottom dimension */ 37 | #define ARRAY_ERR 16 /**< Various errors with array indices */ 38 | #define SUBSTR_ERR 17 /**< Substring specifier out of bounds */ 39 | #define FOR_ERR 18 /**< Error in FOR/ENDFOR loop */ 40 | #define UNFUNC_ERR 19 /**< Unknown function */ 41 | #define PARM_ERR 20 /**< Parameter error in PROC/FUNC call */ 42 | #define VALUE_ERR 21 /**< Error copying values */ 43 | #define OPEN_ERR 22 /**< File open error */ 44 | #define CLOSE_ERR 23 /**< File close error */ 45 | #define POS_ERR 24 /**< File positioning error */ 46 | #define WRITE_ERR 25 /**< File WRITE error */ 47 | #define EOF_ERR 26 /**< Error when checking for EOF */ 48 | #define EOD_ERR 27 /**< EOD at READ */ 49 | #define TYPE_ERR 28 /**< Type mixup with read & input etc. */ 50 | #define READ_ERR 29 /**< I/O error at file READ */ 51 | #define IMPORT_ERR 30 /**< IMPORT error */ 52 | #define NAME_ERR 31 /**< Error in processing a NAME */ 53 | #define ESCAPE_ERR 32 /**< Escape Pressed @ INPUT in direct mode */ 54 | #define MATH_ERR 33 /**< Mathematics Error */ 55 | #define MEM_ERR 34 /**< Memory Error */ 56 | #define SELECT_ERR 35 /**< Error in select input/output */ 57 | #define USING_ERR 36 /**< USING string format error */ 58 | #define INPUT_ERR 37 /**< Error in input */ 59 | #define SQASH_ERR 38 /**< Error at save/load (Sqash) */ 60 | #define SYS_ERR 39 /**< Error at SYS, SYS() or SYS$() */ 61 | #define CMD_ERR 40 /**< Error in OpenComal command */ 62 | #define RUN_ERR 41 /**< Error when executing RUN "filename" */ 63 | #define CURSOR_ERR 42 /**< Error in CURSOR statement */ 64 | #define ID_ERR 43 /**< Error in expression (exp_id()) */ 65 | #define LVAL_ERR 44 /**< Expression is not an lvalue */ 66 | #define SCAN_ERR 45 /**< Error in SCAN of external segment */ 67 | #define EXT_ERR 46 /**< Error in call of external proc/func */ 68 | #define EXT2_ERR 47 /**< Error in call of extension proc/func */ 69 | #define DIRS_ERR 48 /**< Error determining current working dir */ 70 | #define SPC_ERR 49 /**< Error in parameter to SPC$ */ 71 | #define DIR_ERR 50 /**< Error in MKDIR, CHDIR of RMDIR */ 72 | #define RND_ERR 51 /**< Error in the arguments for RND */ 73 | 74 | #endif 75 | -------------------------------------------------------------------------------- /src/pdcexec.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Line execution routines header file 13 | */ 14 | 15 | #ifndef PDCEXEC_H 16 | #define PDCEXEC_H 17 | 18 | #include "compat_cdefs.h" 19 | 20 | /** Signal a run-time error */ 21 | extern void run_error(int error, const char *s, ...); 22 | 23 | /** Call a PROC/FUNC definition */ 24 | extern void exec_call(struct expression *exp, int calltype, 25 | void **result, enum VAL_TYPE *type); 26 | 27 | /** Install an exception handler */ 28 | extern int exec_trap(struct comal_line *line); 29 | 30 | /** Return the metadata for an open file */ 31 | extern struct file_rec *fsearch(long i); 32 | 33 | /** Read from a binary format file */ 34 | extern void do_readfile(struct two_exp *twoexp, 35 | struct exp_list *lvalroot); 36 | 37 | /** Read from in-program DATA statements */ 38 | extern void read_data(struct comal_line *line); 39 | 40 | /** Implement the READ keyword */ 41 | extern void exec_read(struct comal_line *line); 42 | 43 | /** Write to a binary format file */ 44 | extern void exec_write(struct comal_line *line); 45 | 46 | /** Print to a text format file */ 47 | extern void print_file(struct two_exp *twoexp, 48 | struct print_list *printroot, int pr_sep, 49 | struct expression *using_modifier); 50 | 51 | /** Input from a text format file */ 52 | extern void input_file(struct two_exp *twoexp, 53 | struct exp_list *lvalroot); 54 | 55 | /** Execute one line of the program */ 56 | extern int exec_line(struct comal_line *line); 57 | 58 | /** Execute a sequence of lines, in one environment */ 59 | extern void exec_seq(struct comal_line *line); 60 | 61 | /** Initialise any module initialisation statements */ 62 | extern void exec_mod_init(struct comal_line *line); 63 | 64 | #endif 65 | -------------------------------------------------------------------------------- /src/pdcexp.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal expression evaluation header file 13 | */ 14 | 15 | #ifndef PDCEXP_H 16 | #define PDCEXP_H 17 | 18 | /** Retrieve an lval expression */ 19 | extern void *exp_lval(struct expression *exp, enum VAL_TYPE *type, 20 | struct var_item **var, long *strlen); 21 | 22 | /** Calculate the value of/reduce to normal form a compound expression */ 23 | extern void calc_exp(struct expression *exp, void **result, 24 | enum VAL_TYPE *type); 25 | 26 | /** Calculate the value of an expression in an integer context */ 27 | extern long calc_intexp(struct expression *exp); 28 | 29 | /** Calculate the value of an expression in a logical context */ 30 | extern int calc_logexp(struct expression *exp); 31 | 32 | #endif 33 | -------------------------------------------------------------------------------- /src/pdcext.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal 'default' extensions 13 | */ 14 | 15 | #ifndef PDCEXT_H 16 | #define PDCEXT_H 17 | 18 | #include "compat_cdefs.h" 19 | 20 | /** 21 | * Evaluate any SYS(???) expressions 22 | * Unless you require backward-compability with some other implementation, 23 | * this is the recommended way to extend the interpreter. 24 | */ 25 | extern int ext_sys_exp(struct exp_list *exproot, void **result, 26 | enum VAL_TYPE *type); 27 | 28 | /** 29 | * Evaluate any SYS$(???) expressions 30 | * Unless you require backward-compability with some other implementation, 31 | * this is the recommended way to extend the interpreter. 32 | */ 33 | extern int ext_syss_exp(struct exp_list *exproot, 34 | struct string **result, enum VAL_TYPE *type); 35 | 36 | /** 37 | * Execute any "SYS ???" statements 38 | * Unless you require backward-compability with some other implementation, 39 | * this is the recommended way to extend the interpreter. 40 | */ 41 | extern int ext_sys_stat(struct exp_list *exproot); 42 | 43 | /** Handle input from a stream after "SYS SYSIN" */ 44 | extern bool ext_get(int stream, char *line, int maxlen, 45 | const char *prompt); 46 | 47 | /** Handle writing a nl after "SYS SYSOUT" */ 48 | extern bool ext_nl(void); 49 | 50 | /** Handle writing a tab after "SYS SYSOUT" */ 51 | extern bool ext_ht(void); 52 | 53 | /** Handle writing a np after "SYS SYSOUT" */ 54 | extern void ext_page(FILE * f); 55 | 56 | /** Handle output after "SYS SYSOUT" */ 57 | extern bool ext_put(const char *buf); 58 | 59 | #endif 60 | -------------------------------------------------------------------------------- /src/pdcfree.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal routines to free lines 13 | */ 14 | 15 | #ifndef PDCFREE_H 16 | #define PDCFREE_H 17 | 18 | /** Free all storage for one line of a program */ 19 | extern void line_free(struct comal_line *line, int mainprog); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /src/pdcfunc.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Codes for OpenComal functions & constants 13 | */ 14 | 15 | #ifndef PDCFUNC_H 16 | #define PDCFUNC_H 17 | 18 | #define _ABS 4000 19 | #define _ACS 4001 20 | #define _ASN 4002 21 | #define _ATN 4003 22 | #define _CHR 4004 23 | #define _COS 4005 24 | #define _DEG 4006 25 | #define _EOD 4007 26 | #define _EOF 4008 27 | #define _EXP 4009 28 | #define _FALSE 4010 29 | #define _TRUE 4011 30 | #define _INT 4012 31 | #define _LEN 4013 32 | #define _LOG 4014 33 | #define _LOG10 4015 34 | #define _NOT 4016 35 | #define _ORD 4017 36 | #define _PI 4018 37 | #define _RAD 4019 38 | #define _RND 4020 39 | #define _SGN 4021 40 | #define _SIN 4022 41 | #define _SQR 4023 42 | #define _STR 4024 43 | #define _TAN 4025 44 | #define _VAL 4026 45 | 46 | #define _ERR 4027 47 | #define _ERRTEXT 4028 48 | #define _ERRLINE 4029 49 | 50 | #define _DIR 4030 51 | #define _UNIT 4031 52 | #define _SPC 4032 53 | #define _KEY 4033 54 | #define _INKEY 4034 55 | 56 | #define _UPPER 4035 57 | #define _LOWER 4036 58 | #define _FRAC 4037 59 | #define _ROUND 4038 60 | 61 | #define _CURCOL 4039 62 | #define _CURROW 4040 63 | #define _ESC 4041 64 | #define _FREEFILE 4042 65 | #define _GET 4043 66 | #define _ZONE 4044 67 | #define _TAB 4045 68 | 69 | #endif 70 | -------------------------------------------------------------------------------- /src/pdcglob.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * This header file contains declarations global to the entire OpenComal interpreter. 13 | */ 14 | 15 | #ifndef PDCGLOB_H 16 | #define PDCGLOB_H 17 | 18 | #include "pdcconst.h" 19 | #include "pdcsys.h" 20 | #include "pdcdef.h" 21 | #include "pdcmem.h" 22 | #include "pdcerr.h" 23 | #include "pdcmsg.h" 24 | #include "pdcfunc.h" 25 | 26 | #ifndef PDCPARS 27 | #include "pdcpars.tab.h" 28 | #endif 29 | 30 | #include 31 | #include 32 | #include 33 | #ifdef __APPLE__ 34 | #include 35 | #else 36 | #include 37 | #endif 38 | #include 39 | #include 40 | 41 | #define PRIVATE static 42 | #define PUBLIC 43 | 44 | #ifndef EXTERN 45 | #define EXTERN extern 46 | #endif 47 | 48 | #define NO_STRUCTURE (0) /**< return values from scan_necessary */ 49 | #define STRUCTURE_START (1) /**< return values from scan_necessary */ 50 | #define STRUCTURE_END (2) 51 | 52 | #define COMMAND(x) (32767-x) /**< to distinguish between statements & command from (e.q. RUN, DEL) */ 53 | 54 | /* 55 | * RESTART entry codes 56 | */ 57 | 58 | #define JUST_RESTART 1 /**< Nothing special, restart interpreter */ 59 | #define QUIT 2 /**< Restart code = QUIT */ 60 | #define RUN 3 /**< Restart code = RUN */ 61 | #define PROG_END 4 /**< Restart code = end program */ 62 | #define ERR_FATAL 666 /**< fatal error occurred */ 63 | 64 | EXTERN jmp_buf RESTART; /**< restart entry in the interpreter after error */ 65 | EXTERN jmp_buf ERRBUF; /**< Continue point after run_error */ 66 | 67 | EXTERN struct comal_env *curenv; /**< Current COMAL environment */ 68 | EXTERN int entering; /**< ENTER in progress */ 69 | EXTERN bool comal_debug; /**< Internal debugging switch */ 70 | 71 | EXTERN FILE *sel_outfile; /**< For select output */ 72 | EXTERN FILE *sel_infile; /**< For select input */ 73 | 74 | EXTERN char *runfilename; 75 | 76 | EXTERN struct env_list *env_root; 77 | 78 | EXTERN locale_t latin_loc; 79 | EXTERN iconv_t latin_to_utf8; 80 | EXTERN nl_catd catdesc; 81 | 82 | #endif 83 | -------------------------------------------------------------------------------- /src/pdcid.c: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /* 12 | * OpenComal's ID routines 13 | */ 14 | 15 | #define _XOPEN_SOURCE 700 16 | 17 | #include "pdcglob.h" 18 | #include "pdcmisc.h" 19 | #include "pdcid.h" 20 | #include "pdcstr.h" 21 | #include 22 | 23 | PRIVATE struct id_rec *id_root = NULL; 24 | 25 | 26 | /* 27 | * STRCMP was originally used because of 8086 segmentation. I left it in 28 | * there because I'm not sure if the interpreter interns strings. 29 | */ 30 | 31 | PUBLIC int 32 | id_eql(struct id_rec *id1, struct id_rec *id2) 33 | { 34 | return (strcmp(id1->name, id2->name) == 0) ? 1 : 0; 35 | } 36 | 37 | 38 | /* 39 | * The private function install builds a new record in memory for the 40 | * specified id name. Memory is allocated from the free pool. 41 | */ 42 | 43 | PRIVATE struct id_rec * 44 | install(char *idname) 45 | { 46 | struct id_rec *work; 47 | int l = strlen(idname); 48 | 49 | work = 50 | (struct id_rec *) mem_alloc(MISC_POOL, sizeof(struct id_rec) + l); 51 | work->left = work->right = NULL; 52 | term_strncpy(work->name, idname, l + 1); 53 | 54 | switch (work->name[l - 1]) { 55 | case '#': 56 | work->type = V_INT; 57 | break; 58 | case '$': 59 | work->type = V_STRING; 60 | break; 61 | default: 62 | work->type = V_FLOAT; 63 | break; 64 | } 65 | 66 | return work; 67 | } 68 | 69 | /* 70 | * The next routine does the horse work of searching and installing an 71 | * identifier. 72 | */ 73 | 74 | PRIVATE struct id_rec * 75 | id_horse(char *idname) 76 | { 77 | struct id_rec *walk = id_root; 78 | struct id_rec *lastone = NULL; 79 | struct id_rec *installed; 80 | enum { atroot, overleft, overright } lastchoice = atroot; 81 | int found = 0; 82 | 83 | while (walk != NULL && !found) { 84 | int cmp = strcoll_l(idname, walk->name, latin_loc); 85 | 86 | lastone = walk; 87 | 88 | if (cmp < 0) { 89 | lastchoice = overleft; 90 | walk = walk->left; 91 | } else if (cmp > 0) { 92 | lastchoice = overright; 93 | walk = walk->right; 94 | } else 95 | found = 1; 96 | } 97 | 98 | if (found) 99 | return walk; 100 | 101 | installed = install(idname); 102 | 103 | if (lastchoice == atroot) 104 | return (id_root = installed); 105 | else if (lastchoice == overleft) 106 | return (lastone->left = installed); 107 | else 108 | return (lastone->right = installed); 109 | } 110 | 111 | 112 | PUBLIC struct id_rec * 113 | id_search(char *id) 114 | { 115 | char idname[MAX_IDLEN]; 116 | 117 | term_strncpy(idname, id, MAX_IDLEN); 118 | strlwr(idname); 119 | return (struct id_rec *) id_horse(idname); 120 | } 121 | -------------------------------------------------------------------------------- /src/pdcid.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal id routines header file 13 | */ 14 | 15 | #ifndef PDCID_H 16 | #define PDCID_H 17 | 18 | /** 19 | * Compare two identifiers by their handles. 20 | * @return 1 if they are equal and 0 if the two identifiers are unequal 21 | */ 22 | extern int id_eql(struct id_rec *id1, struct id_rec *id2); 23 | 24 | /** 25 | * Search for an identifier and if it is not present installs it. 26 | * @return a handle for the identifier 27 | */ 28 | extern struct id_rec *id_search(char *id); 29 | 30 | #endif 31 | -------------------------------------------------------------------------------- /src/pdclex.l: -------------------------------------------------------------------------------- 1 | %{ 2 | /* 3 | * OpenComal -- a free Comal implementation 4 | * 5 | * This file is part of the OpenComal package. 6 | * (c) Copyright 1992-2002 Jos Visser 7 | * 8 | * The OpenComal package is covered by the GNU General Public 9 | * License. See doc/LICENSE for more information. 10 | */ 11 | 12 | 13 | /********** LEXICAL ANALYSIS for OpenComal **********/ 14 | 15 | #include "pdcglob.h" 16 | #include "pdclexs.h" 17 | #include "pdcparss.h" 18 | #include "pdcmisc.h" 19 | #include "pdcstr.h" 20 | 21 | /* #define PDCLEX_DEBUG 1 */ 22 | 23 | PRIVATE int pdc_input(void); /* Definition for FLEX */ 24 | 25 | #ifdef FLEX 26 | #undef YY_INPUT 27 | #define YY_INPUT(buf,result,maxsize) { *buf=pdc_input(); result=1; } 28 | #endif 29 | 30 | #ifdef PC_LEX 31 | #undef input 32 | #define input() pdc_input() 33 | #endif 34 | 35 | #undef unput 36 | #define YY_NO_UNPUT 37 | 38 | #define UNPUTMAXSTACKSIZE (MAX_LINELEN) 39 | 40 | PRIVATE char curline[MAX_LINELEN]; 41 | PRIVATE int lineptr=0; 42 | 43 | PRIVATE char unputstack[UNPUTMAXSTACKSIZE]; 44 | PRIVATE int unputsp=0; 45 | 46 | #ifdef PDCLEX_DEBUG 47 | #define RETURN(x) { int i=x; printf("FLEX RETURNS:%d (%s)\n",i,yytext); return i; } 48 | #else 49 | #define RETURN(x) return x; 50 | #endif 51 | 52 | %} 53 | 54 | A [Aa] 55 | B [Bb] 56 | C [Cc] 57 | D [Dd] 58 | E [Ee] 59 | F [Ff] 60 | G [Gg] 61 | H [Hh] 62 | I [Ii] 63 | J [Jj] 64 | K [Kk] 65 | L [Ll] 66 | M [Mm] 67 | N [Nn] 68 | O [Oo] 69 | P [Pp] 70 | Q [Qq] 71 | R [Rr] 72 | S [Ss] 73 | T [Tt] 74 | U [Uu] 75 | V [Vv] 76 | W [Ww] 77 | X [Xx] 78 | Y [Yy] 79 | 80 | number [0-9] 81 | letter [A-Za-z'_\xa6\xa8\xb4\xb8\xbe\xc0-\xd6\xd8-\xf6\xf8-\xff] 82 | netter [A-Za-z'_\xa6\xa8\xb4\xb8\xbe\xc0-\xd6\xd8-\xf6\xf8-\xff0-9] 83 | exp [Ee][\-\+]?{number}+ 84 | 85 | %% 86 | [ \t]+ ; 87 | \r?\n RETURN(eolnSYM); 88 | {R}{E}{A}{D}[ \t]+{O}{N}{L}{Y} RETURN(read_onlySYM); 89 | {S}{E}{L}{E}{C}{T}[ \t]+{O}{U}{T}{P}{U}{T} RETURN(select_outputSYM); 90 | {S}{E}{L}{E}{C}{T}[ \t]+{I}{N}{P}{U}{T} RETURN(select_inputSYM); 91 | {A}{N}{D}[ \t]+{T}{H}{E}{N} RETURN(andthenSYM); 92 | {O}{R}[ \t]+{T}{H}{E}{N} RETURN(orthenSYM); 93 | \- RETURN(minusSYM); 94 | \* RETURN(timesSYM); 95 | \+ RETURN(plusSYM); 96 | \/ RETURN(divideSYM); 97 | \^ RETURN(powerSYM); 98 | \( RETURN(lparenSYM); 99 | \) RETURN(rparenSYM); 100 | \? RETURN(printSYM); 101 | \= RETURN(eqlSYM); 102 | \:= RETURN(becomesSYM); 103 | \:\+ RETURN(becplusSYM); 104 | \:\- RETURN(becminusSYM); 105 | \< RETURN(lssSYM); 106 | \<= RETURN(leqSYM); 107 | \<> RETURN(neqSYM); 108 | != RETURN(neqSYM); 109 | \> RETURN(gtrSYM); 110 | \>= RETURN(geqSYM); 111 | \: RETURN(colonSYM); 112 | \; RETURN(semicolonSYM); 113 | \, RETURN(commaSYM); 114 | \# RETURN(fileSYM); 115 | \/\/[^\r\n]* RETURN(lex_rem()); 116 | \"([^\\]\"\"|\\\"|[^\"\n])*\"? RETURN(lex_string_flatten()); 117 | {letter}{netter}* RETURN(lex_id(idSYM)); 118 | {letter}{netter}*\# RETURN(lex_id(intidSYM)); 119 | {letter}{netter}*\$ RETURN(lex_id(stringidSYM)); 120 | {number}+ RETURN(lex_intnum()); 121 | {number}+{exp} RETURN(lex_floatnum()); 122 | {number}+\.{number}+({exp})? RETURN(lex_floatnum()); 123 | . pars_error("Unexpected character 0x%02x",*yytext); 124 | %% 125 | 126 | PUBLIC int yywrap(void) 127 | { 128 | return 1; 129 | } 130 | 131 | PRIVATE void pdc_unput(char c) 132 | { 133 | 134 | #ifdef PDCLEX_DEBUG 135 | printf("PDCLEX UNPUT:%c\n",c); 136 | #endif 137 | 138 | if (unputsp==UNPUTMAXSTACKSIZE) 139 | fatal("UNPUT buffer overflow"); 140 | 141 | unputstack[unputsp++]=c; 142 | } 143 | 144 | 145 | PRIVATE int pdc_input2(void) 146 | { 147 | if (unputsp>0) return unputstack[--unputsp]; 148 | 149 | if (curline[lineptr]=='\0') return '\n'; 150 | 151 | return curline[lineptr++]; 152 | } 153 | 154 | 155 | PRIVATE int pdc_input(void) 156 | { 157 | char c=pdc_input2(); 158 | 159 | #ifdef PDCLEX_DEBUG 160 | printf("PDCLEX INPUT:%c(%d)\n",c,(int)c); 161 | #endif 162 | 163 | return c; 164 | } 165 | 166 | PUBLIC int lex_pos(void) 167 | { 168 | return lineptr-unputsp-1+3-yyleng; 169 | } 170 | 171 | 172 | PUBLIC void lex_setinput(char *line) 173 | { 174 | #ifdef FLEX 175 | yyrestart(NULL); 176 | #endif 177 | 178 | term_strncpy(curline,line,MAX_LINELEN); 179 | lineptr=0; 180 | } 181 | 182 | 183 | PUBLIC void lex_unput(char c) 184 | { 185 | pdc_unput(c); 186 | } 187 | 188 | 189 | PUBLIC int lex_leng(void) 190 | { 191 | return yyleng; 192 | } 193 | 194 | -------------------------------------------------------------------------------- /src/pdclexs.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Header file for lex support routines 13 | */ 14 | 15 | #ifndef PDCLEXS_H 16 | #define PDCLEXS_H 17 | 18 | /** Interpret C-style character escapes */ 19 | extern int lex_string_flatten(void); 20 | 21 | /** 22 | * Store the string value, and parse and store the binary value, of a float. 23 | * @see dubbel 24 | */ 25 | extern int lex_floatnum(void); 26 | 27 | /** Parse and store the binary value of an int */ 28 | extern int lex_intnum(void); 29 | 30 | /** Parse and store an identifier which may be a COMAL built-in or a definition by the programmer */ 31 | extern int lex_id(int sym); 32 | 33 | /** Store a remark */ 34 | extern int lex_rem(void); 35 | 36 | /** Get the text representation of a COMAL built-in symbol */ 37 | extern const char *lex_sym(int sym); 38 | 39 | /** Get the text representation of a COMAL built-in infix operator */ 40 | extern const char *lex_opsym(int sym); 41 | 42 | /* 43 | * These are defined in pdclex.l 44 | */ 45 | extern int lex_leng(void); 46 | extern void lex_unput(char c); 47 | extern int yylex(void); 48 | extern int lex_pos(void); 49 | extern void lex_setinput(char *line); 50 | 51 | #endif 52 | -------------------------------------------------------------------------------- /src/pdclist.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal routines to list program lines 13 | */ 14 | 15 | #ifndef PDCLIST_H 16 | #define PDCLIST_H 17 | 18 | /** List one program line */ 19 | extern void line_list(char **buf, struct comal_line *line); 20 | 21 | #endif 22 | -------------------------------------------------------------------------------- /src/pdcmem.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal memory management header file 13 | */ 14 | 15 | #ifndef PDCMEM_H 16 | #define PDCMEM_H 17 | 18 | #include 19 | #include "compat_cdefs.h" 20 | 21 | #define NR_FIXED_POOLS 4 22 | 23 | #define PARSE_POOL 0 24 | #define RUN_POOL 1 25 | #define MISC_POOL 2 26 | 27 | 28 | #define NRCPOOLS 2 29 | #define INT_CPOOL 0 30 | #define FLOAT_CPOOL 1 31 | 32 | #define GETCORE(p,a) (a *)mem_alloc((p),sizeof(a)) 33 | 34 | /** Tracking info before the start of each allocated block */ 35 | struct mem_block { 36 | struct mem_block *next; 37 | struct mem_block *prev; 38 | int marker; 39 | #ifndef NDEBUG 40 | long size; 41 | #endif 42 | struct mem_pool *pool; 43 | }; 44 | 45 | /** A pool of related allocated memory blocks */ 46 | struct mem_pool { 47 | #ifndef NDEBUG 48 | long size; 49 | #endif 50 | struct mem_block *root; 51 | int id; 52 | }; 53 | 54 | /** Initialise all pools & cells */ 55 | extern void mem_init(void); 56 | 57 | /** Free all allocated pools & cells */ 58 | extern void mem_tini(void); 59 | 60 | /** Allocate a cell */ 61 | extern __malloc void *cell_alloc(unsigned int pool); 62 | 63 | /** 64 | * Private interface to allocate a memory block. 65 | * @see STR_ALLOC_PRIVATE 66 | */ 67 | extern __malloc void *mem_alloc_private(struct mem_pool *pool, 68 | size_t size); 69 | 70 | /** Allocate a memory block in a pool */ 71 | extern __malloc void *mem_alloc(unsigned int pool, size_t size); 72 | 73 | /** Change the size of a memory block */ 74 | extern void *mem_realloc(void *block, long newsize); 75 | 76 | /** Free a cell */ 77 | extern void cell_free(void *m); 78 | 79 | /** Free a memory block */ 80 | extern void *mem_free(void *m); 81 | 82 | /** Free a cell pool */ 83 | extern void cell_freepool(unsigned int pool); 84 | 85 | /* 86 | * Free a pool of memory blocks 87 | */ 88 | extern void mem_freepool(unsigned int pool); 89 | 90 | /** 91 | * Private interface to free a memory block. 92 | * @see prog_new 93 | */ 94 | extern void mem_freepool_private(struct mem_pool *pool); 95 | 96 | /** Move a memory block from one pool to another */ 97 | extern void mem_shiftmem(unsigned int frompool, 98 | struct mem_pool *topool); 99 | 100 | #ifndef NDEBUG 101 | /** Print the size of all pools */ 102 | extern void mem_debug(void); 103 | #endif 104 | 105 | /** Allocate a new memory pool */ 106 | extern struct mem_pool *pool_new(void); 107 | 108 | #endif 109 | -------------------------------------------------------------------------------- /src/pdcmod.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal Routines for external OpenComal modules 13 | */ 14 | 15 | #ifndef PDCMOD_H 16 | #define PDCMOD_H 17 | 18 | /** USE a module */ 19 | extern bool mod_use(struct seg_des *seg, struct id_rec *id, 20 | char *errtxt, struct comal_line **erline); 21 | 22 | /** Find an OpenComal module */ 23 | extern struct mod_entry *mod_find(struct id_rec *id); 24 | 25 | /** 26 | * Find an OpenCOMAL module in a COMAL segment. 27 | * 28 | * @note 29 | * Please note the absolutely confusing name of this function :-) 30 | */ 31 | extern struct comal_line *mod_find_def(struct seg_des *seg, 32 | struct id_rec *id); 33 | 34 | /** Search for a PROC or FUNC in the table of exported routines */ 35 | extern struct comal_line *mod_search_routine(struct id_rec *id, int type); 36 | 37 | /** Free the entire environment of loaded OpenComal modules */ 38 | extern void mod_freeall(void); 39 | 40 | /** Initialize all registered modules */ 41 | extern void mod_initall(void); 42 | 43 | #endif 44 | -------------------------------------------------------------------------------- /src/pdcmsg.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Definitions of the OpenComal message streams 13 | */ 14 | 15 | #ifndef PDCMSG_H 16 | #define PDCMSG_H 17 | 18 | #define MSG_NR_STREAMS 5 19 | 20 | #define MSG_PROGRAM 0 21 | #define MSG_DEBUG 1 22 | #define MSG_ERROR 2 23 | #define MSG_DIALOG 3 24 | #define MSG_TRACE 4 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /src/pdcnana.h: -------------------------------------------------------------------------------- 1 | /** @file 2 | * Configure GNU nana to integrate with OpenCOMAL. 3 | */ 4 | 5 | #ifndef PDCNANA_H 6 | #define PDCNANA_H 7 | 8 | #define I_DEFAULT_HANDLER(e,f,l,p) fatal(p) 9 | #define I_DEFAULT_PARAMS "assert" 10 | #define L_DEFAULT_HANDLER my_printf 11 | #define L_DEFAULT_PARAMS MSG_DEBUG 12 | #include "nana.h" 13 | 14 | #endif 15 | -------------------------------------------------------------------------------- /src/pdcprog.c: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /* 12 | * OpenComal program management functions 13 | */ 14 | 15 | #define _XOPEN_SOURCE 700 16 | 17 | #include "pdcnana.h" 18 | #include "pdcglob.h" 19 | #include "pdcsqash.h" 20 | #include "pdcsym.h" 21 | #include "pdcprog.h" 22 | #include "pdcscan.h" 23 | #include "pdcfree.h" 24 | #include "pdcmisc.h" 25 | #include "pdcenv.h" 26 | #include "pdcexec.h" 27 | #include "pdcmod.h" 28 | 29 | 30 | PUBLIC void 31 | prog_addline(struct comal_line *line) 32 | { 33 | struct comal_line *work = curenv->progroot; 34 | struct comal_line *last = NULL; 35 | int scan = 0; 36 | 37 | while (work && work->ld->lineno < line->ld->lineno) { 38 | last = work; 39 | work = work->ld->next; 40 | } 41 | 42 | if (!work || work->ld->lineno > line->ld->lineno) 43 | line->ld->next = work; 44 | else { 45 | line->ld->next = work->ld->next; 46 | scan = assess_scan(work); 47 | line_free(work, 1); 48 | } 49 | 50 | if (last) { 51 | last->ld->next = line; 52 | 53 | if (scan_necessary(last) == STRUCTURE_START) 54 | line->ld->indent = last->ld->indent + INDENTION; 55 | else 56 | line->ld->indent = last->ld->indent; 57 | } else 58 | curenv->progroot = line; 59 | 60 | curenv->changed = true; 61 | 62 | if (!scan) 63 | scan = assess_scan(line); 64 | 65 | if (scan) 66 | prog_structure_scan(); 67 | } 68 | 69 | 70 | PUBLIC int 71 | prog_del(struct comal_line **root, long from, long to, int 72 | mainprog) 73 | { 74 | struct comal_line *work = *root; 75 | struct comal_line *last = NULL; 76 | struct comal_line *next; 77 | int scan = 0; 78 | 79 | while (work && work->ld->lineno < from) { 80 | last = work; 81 | work = work->ld->next; 82 | } 83 | 84 | while (work && work->ld->lineno <= to) { 85 | next = work->ld->next; 86 | 87 | if (!scan) 88 | scan = assess_scan(work); 89 | 90 | line_free(work, mainprog); 91 | work = next; 92 | } 93 | 94 | if (last) 95 | last->ld->next = work; 96 | else 97 | *root = work; 98 | 99 | return scan; 100 | } 101 | 102 | 103 | PUBLIC long 104 | prog_highest_line(void) 105 | { 106 | struct comal_line *work = curenv->progroot; 107 | struct comal_line *last = NULL; 108 | 109 | if (!work) 110 | return 0L; 111 | 112 | while (work) { 113 | last = work; 114 | work = work->ld->next; 115 | } 116 | 117 | return last->ld->lineno; 118 | } 119 | 120 | PUBLIC void 121 | prog_total_scan(void) 122 | { 123 | char errtxt[MAX_LINELEN]; 124 | struct comal_line *errline = NULL; 125 | 126 | DBG_PRINTF(true, "Total scanning..."); 127 | 128 | curenv->scan_ok = scan_scan(NULL, errtxt, &errline); 129 | 130 | if (!curenv->scan_ok) { 131 | if (errline) 132 | puts_line(MSG_ERROR, errline); 133 | 134 | my_printf(MSG_ERROR, true, "%s", errtxt); 135 | } 136 | } 137 | 138 | 139 | PUBLIC void 140 | prog_new(void) 141 | { 142 | clear_env(curenv); 143 | mem_freepool_private(curenv->program_pool); 144 | } 145 | 146 | 147 | PUBLIC void 148 | prog_load(char *fn) 149 | { 150 | DBG_PRINTF(true, "LOADing %s", fn); 151 | 152 | prog_new(); 153 | curenv->progroot = expand_fromfile(fn); 154 | curenv->changed = false; 155 | } 156 | 157 | 158 | PUBLIC void 159 | prog_run(void) 160 | { 161 | clean_runenv(curenv); 162 | 163 | if (runfilename) { 164 | prog_load(runfilename); 165 | prog_structure_scan(); 166 | mem_free(runfilename); 167 | runfilename = NULL; 168 | } 169 | 170 | curenv->curenv = ROOTENV(); 171 | 172 | prog_total_scan(); 173 | 174 | if (curenv->scan_ok) { 175 | mod_initall(); 176 | exec_seq(curenv->progroot); 177 | } 178 | } 179 | -------------------------------------------------------------------------------- /src/pdcprog.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal program control header file 13 | */ 14 | 15 | #ifndef PDCPROG_H 16 | #define PDCPROG_H 17 | 18 | /** Add a line to the current program, SCANning where necessary */ 19 | extern void prog_addline(struct comal_line *line); 20 | 21 | /** 22 | * Delete a line from the current program. 23 | * This implements the DEL command. 24 | */ 25 | extern int prog_del(struct comal_line **root, long from, long to, 26 | int mainprog); 27 | 28 | /** Returns the current highest line number */ 29 | extern long prog_highest_line(void); 30 | 31 | /** SCAN the whole program */ 32 | extern void prog_total_scan(void); 33 | 34 | /** Delete the whole current program */ 35 | extern void prog_new(void); 36 | 37 | /** 38 | * Load a tokenized program from disk. 39 | * The current program is replaced. 40 | */ 41 | extern void prog_load(char *fn); 42 | 43 | /** Run the current program, or another one stored in a file */ 44 | extern void prog_run(void); 45 | 46 | #endif 47 | -------------------------------------------------------------------------------- /src/pdcrun.c: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /* 12 | * Main file of OpenComal Command loop -- runtime only version 13 | */ 14 | 15 | #define _XOPEN_SOURCE 700 16 | 17 | #include "pdcglob.h" 18 | #include "pdcstr.h" 19 | #include "pdcprog.h" 20 | #include "pdcmisc.h" 21 | #include "pdcrun.h" 22 | 23 | PUBLIC int yydebug = 0; /* To replace YACC's yydebug */ 24 | PUBLIC bool show_exec = false; /* To replace PDCLIST.C's 25 | * show_exec */ 26 | 27 | 28 | PUBLIC const char * 29 | sys_interpreter(void) 30 | { 31 | return "OpenComalRun"; 32 | } 33 | 34 | 35 | PUBLIC const char * 36 | lex_sym(int sym __my_unused) 37 | { 38 | return ""; 39 | } 40 | 41 | 42 | PUBLIC void 43 | line_list(char **buf, struct comal_line *line __my_unused) 44 | { 45 | **buf = '\0'; 46 | } 47 | 48 | 49 | PUBLIC void 50 | comal_loop(int newstate __my_unused) 51 | { 52 | my_printf(MSG_ERROR, true, "Aborting..."); 53 | longjmp(RESTART, QUIT); 54 | } 55 | 56 | PRIVATE char * 57 | get_runfilename(void) 58 | { 59 | char buf[128]; 60 | 61 | if (sys_get 62 | (MSG_DIALOG, buf, sizeof(buf), 63 | "Enter filename of program to execute: ")) 64 | return NULL; 65 | 66 | return my_strdup(MISC_POOL, buf); 67 | } 68 | 69 | PUBLIC void 70 | pdc_go(int argc, char *argv[]) 71 | { 72 | if (argc == 1) 73 | runfilename = get_runfilename(); 74 | else 75 | runfilename = my_strdup(MISC_POOL, argv[1]); 76 | 77 | if (runfilename && !setjmp(ERRBUF) && !setjmp(RESTART)) 78 | prog_run(); 79 | 80 | if (curenv->error) 81 | give_run_err(curenv->errline); 82 | } 83 | -------------------------------------------------------------------------------- /src/pdcrun.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * Main file of OpenComal Command loop -- runtime only version 13 | */ 14 | 15 | #ifndef PDCRUN_H 16 | #define PDCRUN_H 17 | 18 | /** Return the interpreter name, "OpenComalRun" for this version */ 19 | extern const char *sys_interpreter(void); 20 | 21 | /** Stub for the lexer, should never be called */ 22 | extern const char *lex_sym(int sym); 23 | 24 | /** Stub for LIST in the development environment, should never be called */ 25 | extern void line_list(char **buf, struct comal_line *line); 26 | 27 | /** Stub for the command-loop in the development environment, exits the interpreter if called */ 28 | extern void comal_loop(int newstate); 29 | 30 | /** Run the tokenized COMAL program passed in on the command line */ 31 | extern void pdc_go(int argc, char **argv); 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /src/pdcscan.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal program management 13 | */ 14 | 15 | #ifndef PDCSCAN_H 16 | #define PDCSCAN_H 17 | 18 | /** SCAN the current program */ 19 | extern bool scan_scan(struct seg_des *seg, char *errtxt, 20 | struct comal_line **errline); 21 | 22 | /** Partial SCAN to get the indentation right */ 23 | extern void prog_structure_scan(void); 24 | 25 | /** Tests if the line @c line contains a structure command, which forces a SCAN if changed */ 26 | extern int scan_necessary(struct comal_line *line); 27 | 28 | /** Assess whether a SCAN will be required after editing the line @c line */ 29 | extern bool assess_scan(struct comal_line *line); 30 | 31 | #endif 32 | -------------------------------------------------------------------------------- /src/pdcseg.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal external segment routines header file 13 | */ 14 | 15 | #ifndef PDCSEG_H 16 | #define PDCSEG_H 17 | 18 | /** SCAN an external segment */ 19 | extern void seg_total_scan(struct seg_des *seg); 20 | 21 | /** Load a segment statically, one time */ 22 | extern struct seg_des *seg_static_load(struct comal_line *line); 23 | 24 | /** Load a segment dynamically, every time the PROC/FUNC is called */ 25 | extern struct seg_des *seg_dynamic_load(struct comal_line *line); 26 | 27 | /** Free resources associated with a static external segment */ 28 | extern struct seg_des *seg_static_free(struct seg_des *seg); 29 | 30 | /** Free resources associated with a dynamic external segment */ 31 | extern struct seg_des *seg_dynamic_free(struct seg_des *seg); 32 | 33 | /** Free all external segments */ 34 | extern void seg_allfree(void); 35 | 36 | /** Returns the root of the segment lines, or the current program if seg is NULL */ 37 | extern struct comal_line *seg_root(struct seg_des *seg); 38 | 39 | #endif 40 | -------------------------------------------------------------------------------- /src/pdcsqash.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal line squashing functions for save/load purposes header file 13 | */ 14 | 15 | #ifndef PDCSQASH_H 16 | #define PDCSQASH_H 17 | 18 | #define SQ_COPYRIGHT_MSG "OpenComal/Sqash (c) 1992-2002 Muppet Lab" 19 | #define SQ_VERSION 0x1254 20 | #define SQ_MARKER "SqAsH" 21 | 22 | /* 23 | * The sqash items 24 | */ 25 | 26 | #define SQ_ERROR 0 27 | #define SQ_STRING 1 28 | #define SQ_LINE 2 29 | #define SQ_INT 3 30 | #define SQ_DOUBLE 4 31 | #define SQ_EMPTYSTRING 5 32 | #define SQ_EXPLIST 6 33 | #define SQ_EMPTYEXP 7 34 | #define SQ_EXP 8 35 | #define SQ_EMPTYTWOEXP 9 36 | #define SQ_EMPTYLINE 10 37 | #define SQ_1DIMENSION 11 38 | #define SQ_MODIFIER 12 39 | #define SQ_1PARM 13 40 | #define SQ_ENDEXPLIST 14 41 | #define SQ_ID 15 42 | #define SQ_CONTROL 16 43 | #define SQ_REM 17 44 | #define SQ_LD 18 45 | #define SQ_NOEXTERNAL 19 46 | #define SQ_ONETWOEXP 20 47 | #define SQ_TWOEXP 21 48 | #define SQ_IDLIST 22 49 | #define SQ_ENDIDLIST 23 50 | 51 | /** Tokenize & save the current program to a file */ 52 | extern void sqash_2file(char *fname); 53 | 54 | /** Load & detokenize a file, overwriting the current program */ 55 | extern struct comal_line *expand_fromfile(char *fname); 56 | 57 | #endif 58 | -------------------------------------------------------------------------------- /src/pdcstr.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * String routines header file 13 | */ 14 | 15 | #ifndef PDCSTR_H 16 | #define PDCSTR_H 17 | 18 | #include 19 | 20 | /** Duplicate a string using memory from a specified pool */ 21 | extern char *my_strdup(int pool, const char *s); 22 | 23 | /** Compare two COMAL strings */ 24 | extern int str_cmp(struct string *s1, struct string *s2); 25 | 26 | /** Convert a C string to a COMAL string */ 27 | extern struct string *str_make(int pool, const char *s); 28 | 29 | /** Create an empty COMAL string from a pool */ 30 | extern struct string *str_make2(int pool, long len); 31 | 32 | /** Append one COMAL strings to another */ 33 | extern struct string *str_cat(struct string *s1, struct string *s2); 34 | 35 | /** Search for one COMAL string in another, like strstr in C */ 36 | extern long str_search(struct string *needle, struct string *haystack); 37 | 38 | /* 39 | * Copy a COMAL string 40 | */ 41 | extern struct string *str_cpy(struct string *s1, struct string *s2); 42 | 43 | /** Copies a substring of string 2 to string 1 */ 44 | extern struct string *str_partcpy(struct string *s1, struct string *s2, 45 | long from, long to); 46 | 47 | /** Copies string 2 to a substring of string 1 */ 48 | extern struct string *str_partcpy2(struct string *s1, struct string *s2, 49 | long from, long to); 50 | 51 | /** Duplicate a COMAL string */ 52 | extern struct string *str_dup(int pool, struct string *s); 53 | 54 | /** Duplicate a COMAL string, but with a maximum bound */ 55 | extern struct string *str_maxdup(int pool, struct string *s, long n); 56 | 57 | /** Extend the storage allocated for a COMAL string */ 58 | extern void str_extend(int pool, struct string **s, long newlen); 59 | 60 | /** Convert a string from Latin-9 to UTF8 encoding */ 61 | extern char *str_ltou(const char *lstr); 62 | 63 | /** 64 | * Like strncpy, but guarantees that @c dest will be NUL-terminated. 65 | * @param[in,out] dest destination string 66 | * @param[in] src source string 67 | * @param[in] n size of @c dest 68 | */ 69 | static inline char * 70 | term_strncpy(char *dest, const char *src, size_t n) 71 | { 72 | strncpy(dest, src, n - 1); 73 | dest[n - 1] = '\0'; 74 | return dest; 75 | } 76 | 77 | #endif 78 | -------------------------------------------------------------------------------- /src/pdcsym.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal symbol table and related stuff header file 13 | */ 14 | 15 | #ifndef PDCSYM_H 16 | #define PDCSYM_H 17 | 18 | /** Create a new (optionally lexical) environment */ 19 | extern struct sym_env *sym_newenv(bool closed, struct sym_env *prev, 20 | struct sym_env *alias, 21 | struct comal_line *curproc, 22 | const char *name); 23 | 24 | /** Search for a named environment */ 25 | extern struct sym_env *search_env(char *name, struct sym_env *start); 26 | 27 | /** Pop the environment stack back to the specified level */ 28 | extern struct sym_env *search_env_level(int level, struct sym_env *start); 29 | 30 | /** Pop the environment stack back to the level where variables are defined in the current PROC/FUNC */ 31 | extern struct sym_env *sym_newvarenv(struct sym_env *env); 32 | 33 | /** Enter a new symbol in an environment */ 34 | extern struct sym_item *sym_enter(struct sym_env *env, struct id_rec *id, 35 | enum SYM_TYPE type, void *ptr); 36 | 37 | /** Search for a symbol in the currently-visible environments */ 38 | extern struct sym_item *sym_search(struct sym_env *env, struct id_rec *id, 39 | enum SYM_TYPE type); 40 | 41 | /** Free an environment, and optionally all subsequent environments in the list */ 42 | extern struct sym_env *sym_freeenv(struct sym_env *env, int recur); 43 | 44 | /** Create the metadata record for a new variable */ 45 | extern struct var_item *var_newvar(enum VAL_TYPE type, 46 | struct arr_dim *arrdim, long strlen); 47 | 48 | /** Create a new var entry for a REF variable */ 49 | extern struct var_item *var_refvar(struct var_item *lvar, 50 | enum VAL_TYPE type, long strlen, 51 | void *vref); 52 | 53 | /** Create a new name record */ 54 | extern struct name_rec *name_new(struct sym_env *env, 55 | struct expression *exp); 56 | 57 | /** 58 | * Return a pointer to the data area of a variable. 59 | * If this 60 | * variable is a REFerence variable, this function takes that 61 | * into account... 62 | */ 63 | extern void *var_data(struct var_item *var); 64 | 65 | /** Print a symbol environment */ 66 | extern void sym_list(struct sym_env *env, int recurse); 67 | 68 | /** Create a new root environment */ 69 | static inline struct sym_env * 70 | ROOTENV(void) 71 | { 72 | return sym_newenv(1, NULL, NULL, NULL, "_program"); 73 | } 74 | 75 | #endif 76 | -------------------------------------------------------------------------------- /src/pdcsys.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal header file for OS dependent routines 13 | */ 14 | 15 | #ifndef PDCSYS_H 16 | #define PDCSYS_H 17 | 18 | // #define INT_MAX (~(1L<<(8*sizeof(long)-1))) 19 | #define MAXUNSIGNED ((unsigned)~0) 20 | // #define INT_MIN (1L<<(8*sizeof(long)-1)) 21 | 22 | #include "pdcdsys.h" 23 | 24 | #include "pdcunix.h" 25 | 26 | #endif 27 | -------------------------------------------------------------------------------- /src/pdcunix.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal header file for UNIX 13 | * 14 | * This module should depend on the following interfaces *only*: 15 | * 16 | * - ISO C11 17 | * - X/Open 7, incorporating POSIX 2008 18 | * - X/Open Curses, Issue 7 19 | * 20 | * Testing has been done on Linux and macOS. 21 | */ 22 | 23 | #ifndef PDCUNIX_H 24 | #define PDCUNIX_H 25 | 26 | #define HUGE_POINTER /**< no need for this in real OS's */ 27 | #define O_BINARY 0 28 | 29 | #define HOST_OS "UNIX" 30 | #define HOST_OS_CODE 1 /**< Change when adding another OS! */ 31 | #define VERSION "0.3" 32 | #define CLI "" /**< Command Line Interpreter */ 33 | 34 | #define FLEX 35 | 36 | #define HAS_ROUND 37 | 38 | #include 39 | #include 40 | #include 41 | 42 | #endif 43 | -------------------------------------------------------------------------------- /src/pdcval.h: -------------------------------------------------------------------------------- 1 | /* 2 | * OpenComal -- a free Comal implementation 3 | * 4 | * This file is part of the OpenComal package. 5 | * (c) Copyright 1992-2002 Jos Visser 6 | * 7 | * The OpenComal package is covered by the GNU General Public 8 | * License. See doc/LICENSE for more information. 9 | */ 10 | 11 | /** @file 12 | * OpenComal internal data value manipulation header file 13 | */ 14 | 15 | #ifndef PDCVAL_H 16 | #define PDCVAL_H 17 | 18 | /** Print a value to the specified stream */ 19 | extern void val_print(int stream, void *result, enum VAL_TYPE type); 20 | 21 | /** Copy a value, optionally performing data type conversion */ 22 | extern void val_copy(void *to, void *from, enum VAL_TYPE ttype, 23 | enum VAL_TYPE ftype); 24 | 25 | /** Free the storage for a value */ 26 | extern void val_free(void *result, enum VAL_TYPE type); 27 | 28 | /** Perform the specified comparison operation between two values */ 29 | extern int val_cmp(int op, void *r1, void *r2, enum VAL_TYPE t1, 30 | enum VAL_TYPE t2); 31 | 32 | /** Negate a numeric value */ 33 | extern void val_neg(void *value, enum VAL_TYPE type); 34 | 35 | /** Store a new integer value */ 36 | extern long *val_int(long i, void *ptr, enum VAL_TYPE *type); 37 | 38 | /** Store a new float value */ 39 | extern double *val_float(double f, void *ptr, enum VAL_TYPE *type); 40 | 41 | /** Return the value of a numeric expression as a C "double" */ 42 | extern double val_double(struct expression *exp); 43 | 44 | /** Return the value of a numeric expression as a C "long" */ 45 | extern long val_mustbelong(void *val, enum VAL_TYPE type, int freeit); 46 | 47 | /** Add 2 ints, converting to float in case of overflow */ 48 | extern void val_intadd(long *v1, long *v2, void **result, 49 | enum VAL_TYPE *type); 50 | 51 | /** Subtract 2 ints, converting to float in case of underflow */ 52 | extern void val_intsub(long *v1, long *v2, void **result, 53 | enum VAL_TYPE *type); 54 | 55 | /** Multiply 2 ints, converting to float in case of overflow */ 56 | extern void val_intmul(long *v1, long *v2, void **result, 57 | enum VAL_TYPE *type); 58 | 59 | /** Divide 2 ints, converting to float when the result is not whole */ 60 | extern void val_intdiv(long *v1, long *v2, void **result, 61 | enum VAL_TYPE *type); 62 | 63 | #endif 64 | -------------------------------------------------------------------------------- /src/pgcc.mk: -------------------------------------------------------------------------------- 1 | ifdef DEBUG 2 | $(error DEBUG not supported on pgcc) 3 | endif 4 | CC:=$(REALCC) 5 | CFLAGS+=-D_FORTIFY_SOURCE=2 -c11 -Xc 6 | CFLAGS+=-DNDEBUG -fast -Mipa=fast,inline 7 | LDFLAGS+=-fast -Mipa=fast,inline 8 | -------------------------------------------------------------------------------- /src/version.h: -------------------------------------------------------------------------------- 1 | #define OPENCOMAL_VERSION "0.2.7-pre1-work" 2 | #define OPENCOMAL_BUILD "727" 3 | -------------------------------------------------------------------------------- /tools/bumpbuild: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ $# -ne 1 ]; then 4 | echo "Arfle Barfle Gloop?" 5 | exit 1; 6 | fi 7 | 8 | N=$(cat $1) 9 | N=$(expr $N + 1) 10 | echo "$N" >$1 11 | echo "Build number is $N" 12 | -------------------------------------------------------------------------------- /tools/cml-indent: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | for execname in gnuindent gindent indent; do 4 | version=`$execname --version 2>/dev/null` 5 | if test "x$version" != "x"; then 6 | INDENT=$execname 7 | break 8 | fi 9 | done 10 | 11 | if test -z $INDENT; then 12 | echo "OpenCOMAL git pre-commit hook:" 13 | echo "Did not find GNU indent, please install it before continuing." 14 | exit 1 15 | fi 16 | 17 | case `$INDENT --version` in 18 | GNU*) 19 | ;; 20 | default) 21 | echo "Did not find GNU indent, please install it before continuing." 22 | echo "(Found $INDENT, but it doesn't seem to be GNU indent)" 23 | exit 1 24 | ;; 25 | esac 26 | 27 | # Run twice. GNU indent isn't idempotent 28 | # when run once 29 | for i in 1 2; do 30 | $INDENT \ 31 | --original \ 32 | --no-tabs \ 33 | --ignore-profile \ 34 | $* || exit $? 35 | done 36 | -------------------------------------------------------------------------------- /tools/gentar: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | VERSION=$(cat src/VERSION) 4 | cd .. 5 | mv opencomal opencomal-$VERSION 6 | tar czvf opencomal-$VERSION.tar.gz --exclude=CVS opencomal-$VERSION 7 | mv opencomal-$VERSION opencomal 8 | mv opencomal-$VERSION.tar.gz html 9 | ls -l html/opencomal-$VERSION.tar.gz 10 | -------------------------------------------------------------------------------- /tools/genversion: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | VERSION=$(cat VERSION) 4 | BUILD=$(cat BUILD) 5 | echo "#define OPENCOMAL_VERSION \"$VERSION\"" >version.h 6 | echo "#define OPENCOMAL_BUILD \"$BUILD\"" >>version.h 7 | --------------------------------------------------------------------------------